ADA Programming Guide

home *** CD-ROM | disk | FTP | other *** search

/ ADA Programming Guide / ADA Programming Guide.iso / adatutor / csparts / cspartb2.src < prev next >

Wrap

Text File | 1996-01-30 | 338KB | 10,449 lines

--:::::::::: --fof.bdy --:::::::::: -- ********************************** -- * * -- * FOF_Command_Symbols * SPEC & BODY -- * * -- ********************************** package FOF_Command_Symbols is --| Purpose --| FOF_Command_Symbols contains the error messages issued by --| routines within the package body of FOF. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 04/22/90 Rick Conn Initial Version Error_Internal_Break_Line : constant STRING := "Internal error in FOF.Break_Line"; Error_Internal_Break_Page_1 : constant STRING := "Internal error in FOF.Break_Page (1st routine)"; Error_Internal_Break_Page_2 : constant STRING := "Internal error in FOF.Break_Page (2nd routine)"; Error_Internal_Bottom : constant STRING := "Internal error in FOF.Output_Bottom_Of_Page"; Error_Internal_Hf_Line : constant STRING := "Internal error in FOF.Put_Header_Footer_Line"; Error_Internal_Pnum : constant STRING := "Internal error in FOF.Pnum_As_String"; Error_Internal_Put_Invisible : constant STRING := "Internal error in FOF.Put_Invisible_Word"; Error_Internal_Put_Line : constant STRING := "Internal error in FOF.Put_Line"; Error_Internal_Put_What : constant STRING := "Internal error in FOF.Put_Word.Put_What"; Error_Internal_Put_Word : constant STRING := "Internal error in FOF.Put_Word"; Error_Internal_Set_Footer_Line : constant STRING := "Internal error in FOF.Set_Footer_Line"; Error_Internal_Set_Header_Line : constant STRING := "Internal error in FOF.Set_Header_Line"; Error_Internal_Skip : constant STRING := "Internal error in FOF.Skip"; Error_Internal_Top : constant STRING := "Internal error in FOF.Output_Top_Of_Page"; end FOF_Command_Symbols; package FOF_DYN is -- This package is derived from DSTR3.SRC in the Ada Software Repository -- DSTR3.SRC was written by R.G. Cleaveland. The derivation, done by -- Richard Conn, was done to remove those general-purpose features of the -- package not needed for the PTF project. ------------------------------------------------------------------------------ -- This is a package of several string manipulation functions based on -- -- a built-in dynamic STRING type DYN_STRING. It is an adaptation and -- -- extension of the package proposed by Sylvan Rubin of Ford Aerospace and -- -- Communications Corporation in the Nov/Dec 1984 issue of the Journal of -- -- Pascal, Ada and Modula-2. Some new functions have been added, and much -- -- of the body code has been rewritten. -- ------------------------------------------------------------------------------ -- R.G. Cleaveland 07 December 1984: -- -- Implementation initially with the Telesoft Ada version 1.3. -- -- 06 Feb 85: CHAR changed to add the optional parameter POSIT. -- -- 06 Feb 85: procedure SUBSTITUTE added. -- -- 05 Apr 85: procedures UPPERCASE and CHECKBYTE added. -- -- 04 Feb 86: style and formatting changes made, some comments fixed. -- -- Ported to VERDIX VADS (VAX Ultrix version 5.1). -- -- 10 Feb 86: Several bugs fixed - SIZE constrained, exception for '&' -- -- generating too long a string added, error in integer conversion fixed. -- -- Functions EQUALS, ">", "<=" and ">=" added. Subtype DS_POS incorporated.-- ------------------------------------------------------------------------------ MAX_D_STRING_LENGTH : constant POSITIVE := 100; -- This is the maximum LENGTH of a dynamic string implemented with this -- package. This value is "arbitrary" in that any reasonable number -- equal to or less than the maximum STRING LENGTH permitted by the -- compiler is acceptable. The specific value above was chosen as a -- compromise between programmer convenience and memory space requirements. subtype DS_POS is INTEGER range 0..MAX_D_STRING_LENGTH; type DYN_STRING is private; STRING_TOO_SHORT: exception; function D_STRING(CHAR: CHARACTER) return DYN_STRING; -- Creates a one-byte dynamic string of contents CHAR. function D_STRING(STR : STRING ) return DYN_STRING; -- Creates a dynamic string of contents STR. function CHAR(DSTR : DYN_STRING; POSIT : POSITIVE := 1) return CHARACTER; function STR (DSTR: DYN_STRING) return STRING; function LENGTH(DSTR: DYN_STRING) return NATURAL; -- returns the LENGTH of the dynamic string. procedure CLEAR(DSTR: in out DYN_STRING); -- makes DSTR a null string. private type DYN_STRING is record SIZE: INTEGER range 0..MAX_D_STRING_LENGTH; DATA: STRING(1..MAX_D_STRING_LENGTH); end record; end FOF_DYN; package body FOF_DYN is procedure CLEAR(DSTR: in out DYN_STRING) is begin DSTR.SIZE := 0; end CLEAR; function D_STRING(CHAR: CHARACTER) return DYN_STRING is DS : DYN_STRING; begin DS.SIZE := 1; DS.DATA(1) := CHAR; return DS; end D_STRING; function D_STRING(STR : STRING ) return DYN_STRING is DS : DYN_STRING; begin DS.SIZE := STR'LENGTH; DS.DATA(1..DS.SIZE) := STR; return DS; end D_STRING; function CHAR(DSTR : DYN_STRING; POSIT : POSITIVE := 1) return CHARACTER is begin if POSIT > DSTR.SIZE then raise STRING_TOO_SHORT; else return DSTR.DATA(POSIT); end if; end CHAR; function STR (DSTR: DYN_STRING) return STRING is begin return DSTR.DATA(1..DSTR.SIZE); end STR; function LENGTH(DSTR: DYN_STRING) return NATURAL is begin return DSTR.SIZE; end LENGTH; begin --(FOF_DYN) null; exception when others => raise; end FOF_DYN; -- ********************************** -- * * -- * FOF_Error_Log * SPEC -- * * -- ********************************** package FOF_Error_Log is --| Purpose --| FOF_Error_Log is used to log errors to an output file or console. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version -- .................................. -- . . -- . Open . SPEC -- . . -- .................................. procedure Open ( File_Name : in STRING ); --| Purpose --| Open the error log file. If the File_Name is empty, error log --| goes to standard output. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Write_Error . SPEC -- . . -- .................................. procedure Write_Error ( Message : in STRING ); --| Purpose --| Write_Error makes an error message entry into the error log file. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Write_Warning . SPEC -- . . -- .................................. procedure Write_Warning ( Message : in STRING ); --| Purpose --| Write_Warning makes a warning message entry into the error log file. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Close . SPEC -- . . -- .................................. procedure Close; --| Purpose --| Close closes the error log file. --| --| Exceptions (none) --| Notes (none) end FOF_Error_Log; -- ********************************** -- * * -- * FOF_Output_File * SPEC -- * * -- ********************************** package FOF_Output_File is --| Purpose --| FOF_Output_File implements an abstract data type of an output file. --| FOF_Output_File offers an abstraction that can be made more efficient --| by not using Text_IO (and having its associated overhead imposed) --| if possible and also offers the ability to suppress the output, --| which may be desired if a caller is skipping over pages and just --| wants to output to a null device during this process. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version type FILE_TYPE is private; Cannot_Create_Output_File : exception; Write_Error : exception; -- .................................. -- . . -- . Already_Exists . SPEC -- . . -- .................................. function Already_Exists ( File_Name : in STRING ) return BOOLEAN; --| Purpose --| Determine if the FILE_TYPE object already exists. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Delete . SPEC -- . . -- .................................. function Delete ( File_Name : in STRING ) return BOOLEAN; --| Purpose --| Delete the FILE_TYPE object. Return TRUE if successful. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Create . SPEC -- . . -- .................................. procedure Create ( Id : in out FILE_TYPE; File_Name : in STRING ); --| Purpose --| Create creates a new FILE_TYPE object. --| --| Exceptions --| Cannot_Create_Output_File --| --| Notes (none) -- .................................. -- . . -- . Put . SPEC -- . . -- .................................. procedure Put ( Id : in out FILE_TYPE; Item : in CHARACTER ); procedure Put ( Id : in out FILE_TYPE; Item : in STRING ); --| Purpose --| Put writes an Item to the FILE_TYPE object. --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . Put_Line . SPEC -- . . -- .................................. procedure Put_Line ( Id : in out FILE_TYPE; Item : in STRING ); --| Purpose --| Put_Line writes an Item to the FILE_TYPE object. The Item is followed --| by a New_Line; --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . New_Line . SPEC -- . . -- .................................. procedure New_Line ( Id : in out FILE_TYPE ); --| Purpose --| New_Line writes an end-of-line sequence to the FILE_TYPE object. --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . New_Page . SPEC -- . . -- .................................. procedure New_Page ( Id : in out FILE_TYPE ); --| Purpose --| New_Page writes an end-of-page sequence to the FILE_TYPE object. --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . Enable_Output . SPEC -- . Disable_Output . -- . . -- .................................. procedure Enable_Output ( Id : in out FILE_TYPE ); procedure Disable_Output ( Id : in out FILE_TYPE ); --| Purpose --| Enable_Output and Disable_Output enable and disable the output of --| Items and new lines to the FILE_TYPE object. When created, output --| to a FILE_TYPE object is enabled. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Close . SPEC -- . . -- .................................. procedure Close ( Id : in out FILE_TYPE ); --| Purpose --| Close closes output to the FILE_TYPE object. --| --| Exceptions (none) --| Notes (none) private -- FOF_Output_File type FILE_OBJECT; type FILE_TYPE is access FILE_OBJECT; end FOF_Output_File; -- ********************************** -- * * -- * FOF_Error_Log * BODY -- * * -- ********************************** with FOF_Output_File; with TEXT_IO; package body FOF_Error_Log is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version Is_Open : BOOLEAN := false; Error_File : FOF_Output_File.File_Type; Output_To_Stdio : BOOLEAN := false; Error_Count : NATURAL := 0; Warning_Count : NATURAL := 0; -- .................................. -- . . -- . Open . BODY -- . . -- .................................. procedure Open ( File_Name : in STRING ) is --| Notes (none) begin -- Open if File_Name'Length > 0 then FOF_Output_File.Create(Error_File, File_Name); Is_Open := true; Output_To_Stdio := false; else Is_Open := true; Output_To_Stdio := true; end if; exception -- Open -- Open -- Open when others => Is_Open := true; Output_To_Stdio := true; end Open; -- .................................. -- . . -- . Write_Error . BODY -- . . -- .................................. procedure Write_Error ( Message : in STRING ) is --| Notes (none) begin -- Write_Error if not Is_Open then Open(""); end if; if Output_To_Stdio then TEXT_IO.Put("FOF Error: " & Message); else FOF_Output_File.Put(Error_File, "FOF Error: " & Message); end if; Error_Count := Error_Count + 1; end Write_Error; -- .................................. -- . . -- . Write_Warning . BODY -- . . -- .................................. procedure Write_Warning ( Message : in STRING ) is --| Notes (none) begin -- Write_Warning if not Is_Open then Open(""); end if; if Output_To_Stdio then TEXT_IO.Put("FOF Warning: " & Message); else FOF_Output_File.Put(Error_File, "FOF Warning: " & Message); end if; Warning_Count := Warning_Count + 1; end Write_Warning; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close is --| Notes (none) begin -- Close if Is_Open then if not Output_To_Stdio then FOF_Output_File.Close(Error_File); end if; end if; TEXT_IO.Put(" "); if Error_Count = 0 then TEXT_IO.Put("No Errors, "); else TEXT_IO.Put(NATURAL'Image(Error_Count) & " Error(s), "); end if; if Warning_Count = 0 then TEXT_IO.Put("No Warnings"); else TEXT_IO.Put(NATURAL'Image(Warning_Count) & " Warning(s)"); end if; TEXT_IO.New_Line; end Close; end FOF_Error_Log; -- ********************************** -- * * -- * FOF_Output_File * BODY -- * * -- ********************************** with Text_IO; package body FOF_Output_File is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version --| 02/26/90 Rick Conn Fix bug in Already_Exists test type FILE_OBJECT is record File : Text_IO.File_Type; Is_Open : BOOLEAN := false; Is_Output_Enabled : BOOLEAN := true; end record; -- .................................. -- . . -- . Already_Exists . BODY -- . . -- .................................. function Already_Exists ( File_Name : in STRING ) return BOOLEAN is --| Notes (none) File : Text_IO.File_Type; Result : BOOLEAN := true; begin -- Already_Exists begin Text_IO.Open(File, Text_IO.In_File, File_Name); Text_IO.Close(File); exception when others => Result := false; end; return Result; end Already_Exists; -- .................................. -- . . -- . Delete . BODY -- . . -- .................................. function Delete ( File_Name : in STRING ) return BOOLEAN is --| Notes (none) File : Text_IO.File_Type; Result : BOOLEAN := true; begin -- Delete begin if Already_Exists(File_Name) then Text_IO.Open(File, Text_IO.Out_File, File_Name); Text_IO.Delete(File); end if; exception when others => Result := false; end; return Result; end Delete; -- .................................. -- . . -- . Create . BODY -- . . -- .................................. procedure Create ( Id : in out File_Type; File_Name : in STRING ) is --| Notes (none) begin -- Create Id := new FILE_OBJECT; Text_IO.Create(Id.File, Text_IO.Out_File, File_Name); Id.Is_Open := true; Id.Is_Output_Enabled := true; exception -- Create -- Create when others => raise Cannot_Create_Output_File; end Create; -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Id : in out File_Type; Item : in CHARACTER ) is --| Notes (none) begin -- Put if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put(Id.File, Item); end if; exception -- Put -- Put when others => raise Write_Error; end Put; -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Id : in out File_Type; Item : in STRING ) is --| Notes (none) begin -- Put if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put(Id.File, Item); end if; exception -- Put -- Put when others => raise Write_Error; end Put; -- .................................. -- . . -- . Put_Line . BODY -- . . -- .................................. procedure Put_Line ( Id : in out File_Type; Item : in STRING ) is --| Notes (none) begin -- Put_Line if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put_Line(Id.File, Item); end if; exception -- Put_Line -- Put_Line when others => raise Write_Error; end Put_Line; -- .................................. -- . . -- . New_Line . BODY -- . . -- .................................. procedure New_Line ( Id : in out File_Type ) is --| Notes (none) begin -- New_Line if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.New_Line(Id.File); end if; exception -- New_Line -- New_Line when others => raise Write_Error; end New_Line; -- .................................. -- . . -- . New_Page . BODY -- . . -- .................................. procedure New_Page ( Id : in out File_Type ) is --| Notes (none) begin -- New_Page if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.New_Page(Id.File); end if; exception -- New_Page -- New_Page when others => raise Write_Error; end New_Page; -- .................................. -- . . -- . Enable_Output . BODY -- . . -- .................................. procedure Enable_Output ( Id : in out File_Type ) is --| Notes (none) begin -- Enable_Output Id.Is_Output_Enabled := true; end Enable_Output; -- .................................. -- . . -- . Disable_Output . BODY -- . . -- .................................. procedure Disable_Output ( Id : in out File_Type ) is --| Notes (none) begin -- Disable_Output Id.Is_Output_Enabled := false; end Disable_Output; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Id : in out File_Type ) is --| Notes (none) begin -- Close if Id.Is_Open then Text_IO.Close(Id.File); end if; end Close; end FOF_Output_File; -- ********************************** -- * * -- * Formatted_Output_File * BODY -- * * -- ********************************** with FOF_Command_Symbols; with FOF_DYN; with FOF_Error_Log; with FOF_Output_File; package body Formatted_Output_File is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial version --| 02/26/90 Rick Conn Remove trailing spaces from @n subtype HF is FOF_DYN.Dyn_String; type HF_SECTION is ( LEFT, CENTER, RIGHT ); type HF_LINES is array (Header_Footer_Line, HF_SECTION) of HF; Header_Footer_Default : constant HF_LINES := (others => (others => FOF_DYN.D_String(" "))); subtype LINE is -- very long line for STRING (1 .. Maximum_Line_Length * 5); -- invisible words type FILE_OBJECT is record Output_Is_Open : BOOLEAN := false; -- has file been opened? Output_Is_Empty : BOOLEAN; -- has anything been output? Line_Is_Empty : BOOLEAN; -- is anything in Current_Line? Page_Attr : Page_Attribute_List; -- left margin, etc. Line_Attr : Line_Attribute_List; -- fill, etc (misnomer) Page_Num : Page_Number; -- # of current page Line_Num : Line_Number; -- # of line now being built Even_Header : HF_LINES; -- for even pages Odd_Header : HF_LINES; -- for odd pages Even_Footer : HF_LINES; -- for even pages Odd_Footer : HF_LINES; -- for odd pages Current_Line : LINE; -- line being built Index : NATURAL; -- index of next char to place -- into Current_Line Char_Count : NATURAL; -- number of visible chars -- in Current_Line Last_Char : CHARACTER; -- last char in Current_Line Page_Number_Id : CHARACTER; -- xlates into page number -- in headers and footers Pn_Format : Numeric_Format; -- arabic, lower_ & upper_roman Pn_String : FOF_DYN.Dyn_String; -- text of page number File_Id : FOF_Output_File.File_Type; end record; use FOF_Command_Symbols; -- .................................. -- . . -- . Is_Punctuation . SPEC & BODY -- . . -- .................................. function Is_Punctuation ( Item : in CHARACTER ) return BOOLEAN is --| Purpose --| Is_Punctuation returns TRUE if Item is one of the characters in --| PUNCTUATION_CHARS. --| --| Exceptions (none) --| Notes (none) Result : BOOLEAN := false; begin -- Is_Punctuation case Item is when '.' | ',' | '!' | '?' | ';' => Result := true; when others => Result := false; end case; return Result; end Is_Punctuation; -- .................................. -- . . -- . Simple_Break_Page . SPEC -- . . -- .................................. procedure Simple_Break_Page ( Item : in File ); -- .................................. -- . . -- . Pnum_As_String . SPEC & BODY -- . . -- .................................. function Pnum_As_String ( Value : in Page_Number; Format : in Numeric_Format ) return STRING is --| Purpose --| Pnum_As_String outputs a string (with optional leading blanks) --| which contains the input number's representation in ARABIC, --| LOWER_ROMAN, or UPPER_ROMAN forms. --| --| Exceptions (none) --| --| Notes --| Value should be less than 1000 if output as a Roman numeral. Result : STRING (1 .. 20) := (others => ' '); Rover -- Set for leading space : NATURAL := Result'First; Ones : NATURAL := 0; Tens : NATURAL := 0; Hundreds : NATURAL := 0; -- .................................. -- . . -- . Pnum_As_String.Put . SPEC & BODY -- . . -- .................................. procedure Put ( Item : in CHARACTER ) is --| Purpose --| Put places a character into the Result buffer, incrementing Rover. --| --| Exceptions (none) --| Notes (none) begin -- Put Rover := Rover + 1; Result(Rover) := Item; end Put; -- .................................. -- . . -- . Pnum_As_String.Output . SPEC & BODY -- . . -- .................................. procedure Output ( Value : in NATURAL; Lower : in CHARACTER; Middle : in CHARACTER; Upper : in CHARACTER ) is --| Purpose --| Output outputs the appropriate Roman characters representing --| Value into the string Result, incrementing the pointer Rover --| as it goes. Value must be between 1 and 9, inclusive. --| --| Exceptions (none) --| Notes (none) begin -- Output if Value < 4 then for I in 1 .. Value loop Put(Lower); end loop; elsif Value = 4 then Put(Lower); Put(Middle); elsif (Value >= 5) and (Value < 9) then Put(Middle); if Value > 5 then for I in 1 .. Value - 5 loop Put(Lower); end loop; end if; else Put(Lower); Put(Upper); end if; end Output; -- .................................. -- . . -- . Pnum_As_String.Divide . SPEC & BODY -- . . -- .................................. procedure Divide ( Value : in NATURAL ) is --| Purpose --| Divide sets the number of Thousands, Hundreds, Tens, and Ones --| in the passed value for Roman numeral computation. --| --| Exceptions (none) --| Notes (none) Temp : NATURAL := Value; begin -- Divide if Temp >= 100 then Hundreds := Temp / 100; Temp := Temp - Hundreds * 100; end if; if Temp >= 10 then Tens := Temp / 10; Temp := Temp - Tens * 10; end if; Ones := Temp; end Divide; begin -- Pnum_As_String case Format is when Arabic => return Page_Number'Image(Value); when Lower_Roman => if NATURAL(Value) >= 1000 then Put('z'); Put('z'); Put('z'); else Divide(NATURAL(Value)); if Hundreds > 0 then Output(Hundreds, 'c', 'd', 'm'); end if; if Tens > 0 then Output(Tens, 'x', 'l', 'c'); end if; if Ones > 0 then Output(Ones, 'i', 'v', 'x'); end if; end if; when Upper_Roman => if NATURAL(Value) >= 1000 then Put('Z'); Put('Z'); Put('Z'); else Divide(NATURAL(Value)); if Hundreds > 0 then Output(Hundreds, 'C', 'D', 'M'); end if; if Tens > 0 then Output(Tens, 'X', 'L', 'C'); end if; if Ones > 0 then Output(Ones, 'I', 'V', 'X'); end if; end if; end case; return Result(1 .. Rover); exception when others => FOF_Error_Log.Write_Error(Error_Internal_Pnum); return " "; end Pnum_As_String; -- .................................. -- . . -- . Start_Line . SPEC & BODY -- . . -- .................................. procedure Start_Line ( Item : in File ) is --| Purpose --| This is an internal routine not specified in the package --| specification. It is used to initialize the Current_Line --| field of the Item object and the associated fields. It sets --| the left margin. --| --| Exceptions (none) --| Notes (none) begin -- Start_Line if Item.Page_Attr(Temp_Indent) > 0 then Item.Index := Item.Page_Attr(Temp_Indent) + Item.Page_Attr(Page_Offset); Item.Page_Attr(Temp_Indent) := 0; else Item.Index := Item.Page_Attr(Left_Margin) + Item.Page_Attr(Left_Indent) + Item.Page_Attr(Page_Offset); end if; if Item.Index < 1 then Item.Index := 1; end if; Item.Char_Count := Item.Index - 1; Item.Current_Line(1 .. Item.Index) := (others => ' '); Item.Last_Char := ' '; Item.Line_Is_Empty := false; end Start_Line; -- .................................. -- . . -- . Space_Lines . SPEC & BODY -- . . -- .................................. procedure Space_Lines ( Item : in File ) is --| Purpose --| This is an internal routine not specified in the package --| specification. It is used to output additional blank lines --| based on the LINE_SPACING setting. --| --| Exceptions (none) --| Notes (none) begin -- Space_Lines if Item.Page_Attr(Line_Spacing) > 0 then if Test_Page(Item, Line_Number(Item.Page_Attr(Line_Spacing))) then for I in 1 .. Item.Page_Attr(Line_Spacing) loop FOF_Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; else Simple_Break_Page(Item); end if; end if; end Space_Lines; -- .................................. -- . . -- . Justify_Line . SPEC & BODY -- . . -- .................................. procedure Justify_Line ( Item : in File ) is --| Notes --| This is an internal routine not specified in the package --| specification. It is used to fill the Current_Line --| with spaces so that the last character is on the right --| margin. --| --| Exceptions (none) --| Notes (none) Spaces_Required : constant NATURAL := Item.Page_Attr(Right_Margin) - Item.Page_Attr(Right_Indent) - Item.Char_Count + Item.Page_Attr(Page_Offset); Spaces_Left : NATURAL := Spaces_Required; -- .................................. -- . . -- . Justify_Line.Justify . SPEC & BODY -- . . -- .................................. function Justify ( Amount_Left : in NATURAL ) return NATURAL is --| Purpose --| Justify replaces single spaces in Item.Current_Line with --| double spaces until Amount is zero or the end of the --| line is reached. --| --| Exceptions (none) --| Notes (none) type PARSE_STATE is ( BEFORE_TEXT, IN_TEXT, IN_SPACES, DONE ); State : PARSE_STATE := BEFORE_TEXT; I -- index for Temp : NATURAL; Amount -- number of spaces to go : NATURAL := Amount_Left; Temp : LINE; Was_In_Spaces : BOOLEAN := false; begin -- Justify I := 1; for J in 1 .. Item.Index - 1 loop case State is when BEFORE_TEXT => Temp(I) := Item.Current_Line(J); I := I + 1; if Item.Current_Line(J) > ' ' then State := IN_TEXT; end if; when IN_TEXT => if Item.Current_Line(J) = ' ' then Temp(I) := ' '; I := I + 1; Temp(I) := ' '; I := I + 1; Amount := Amount - 1; Was_In_Spaces := true; if Amount = 0 then State := DONE; else State := IN_SPACES; end if; else Temp(I) := Item.Current_Line(J); I := I + 1; end if; when IN_SPACES => Temp(I) := Item.Current_Line(J); I := I + 1; if Item.Current_Line(J) /= ' ' then State := IN_TEXT; end if; when DONE => Temp(I) := Item.Current_Line(J); I := I + 1; end case; end loop; Item.Current_Line := Temp; Item.Index := I; if not Was_In_Spaces then Amount := 0; end if; return Amount; end Justify; begin -- Justify_Line while Spaces_Left > 0 loop Spaces_Left := Justify(Spaces_Left); end loop; end Justify_Line; -- .................................. -- . . -- . Conditional_Break_Page . SPEC & BODY -- . . -- .................................. procedure Conditional_Break_Page ( Item : in File ) is --| Purpose --| Checks to see if there are any lines left on the page and --| calls Break_Page if not. --| --| Exceptions (none) --| Notes (none) begin -- Conditional_Break_Page if INTEGER(Item.Line_Num) > Item.Page_Attr(Total_Lines) - (Item.Page_Attr(Bottom_Margin) + Item.Page_Attr(Footer_Lines)) then Simple_Break_Page(Item); end if; end Conditional_Break_Page; -- .................................. -- . . -- . Put_Header_Footer_Line . SPEC & BODY -- . . -- .................................. procedure Put_Header_Footer_Line ( Item : in File; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING; Page_Num : in STRING ) is --| Purpose --| This is an internal routine not specified in the package --| specification. It outputs a header or a footer line, placing --| the Page_Num string (which MUST be created by Current_Page) into --| it wherever the Item.Page_Number_Id character is found. The --| Left_Text string is left-justified against the left margin --| (first character starts on the left margin), the Center_Text --| string is centered between the left and right margins, and --| the Right_Text string is right-justified against the right --| margin (the last character falls on the right margin). --| --| Exceptions (none) --| Notes (none) Hf_Line : LINE := (others => ' '); Hf_Last : NATURAL := Item.Page_Attr(Right_Margin) + Item.Page_Attr(Page_Offset); Hf_Last_Save : NATURAL; Left_Text_Lower : constant NATURAL := Item.Page_Attr(Left_Margin) + Item.Page_Attr(Page_Offset); Left_Text_Upper : NATURAL; Right_Text_Lower : NATURAL; Right_Text_Upper : constant NATURAL := Item.Page_Attr(Right_Margin) + Item.Page_Attr(Page_Offset); Center_Point : constant NATURAL := (Right_Text_Upper - Left_Text_Lower) / 2 + Left_Text_Lower; Center_Text_Lower : NATURAL; Center_Text_Upper : NATURAL; Temp_String : LINE; Temp_Length : NATURAL; -- .............................................. -- . . -- . Put_Header_Footer_Line.Build_Temp_String . SPEC & BODY -- . . -- .............................................. procedure Build_Temp_String ( Str : in STRING ) is --| Purpose --| Build_Temp_String analyzes the input string for the Page_Number_Id --| character, building a new output string in the global Temp_String --| vector which contains the input string with the literal page --| number substituted for the Page_Number_Id character. --| --| Exceptions (none) --| Notes (none) J : NATURAL := 1; begin -- Build_Temp_String for I in Str'First .. Str'Last loop if Str(I) = Item.Page_Number_Id then for K in Page_Num'Range loop Temp_String(J) := Page_Num(K); J := J + 1; end loop; else Temp_String(J) := Str(I); J := J + 1; end if; end loop; Temp_Length := J - 1; J := 0; -- remove trailing spaces for I in reverse 1 .. Temp_Length loop if Temp_String(I) > ' ' then J := I; exit; end if; end loop; Temp_Length := J; Left_Text_Upper := Item.Page_Attr(Left_Margin) + Temp_Length - 1 + Item.Page_Attr(Page_Offset); Right_Text_Lower := Item.Page_Attr(Right_Margin) - Temp_Length + 1 + Item.Page_Attr(Page_Offset); Center_Text_Lower := Center_Point - Temp_Length / 2; Center_Text_Upper := Center_Text_Lower + Temp_Length - 1; end Build_Temp_String; begin -- Put_Header_Footer_Line if Left_Text'Length > 0 then Build_Temp_String(Left_Text); if Temp_Length < Right_Text_Upper - Left_Text_Lower + 1 then Hf_Line(Left_Text_Lower .. Left_Text_Upper) := Temp_String(1 .. Temp_Length); else Hf_Line(Left_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. (Right_Text_Upper - Left_Text_Lower + 1)); end if; end if; if Right_Text'Length > 0 then Build_Temp_String(Right_Text); if Temp_Length < Right_Text_Upper - Left_Text_Lower + 1 then Hf_Line(Right_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. Temp_Length); else Hf_Line(Left_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. (Right_Text_Upper - Left_Text_Lower + 1)); end if; end if; if Center_Text'Length > 0 then Build_Temp_String(Center_Text); if Temp_Length < Right_Text_Upper - Left_Text_Lower + 1 then Hf_Line(Center_Text_Lower .. Center_Text_Upper) := Temp_String(1 .. Temp_Length); else Hf_Line(Left_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. (Right_Text_Upper - Left_Text_Lower + 1)); end if; end if; Hf_Last_Save := Hf_Last; Hf_Last := 1; for I in reverse 1 .. Hf_Last_Save loop if Hf_Line(I) /= ' ' then Hf_Last := I; exit; end if; end loop; FOF_Output_File.Put_Line(Item.File_Id, Hf_Line(1 .. Hf_Last)); Item.Line_Num := Item.Line_Num + 1; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Hf_Line); end Put_Header_Footer_Line; -- .................................. -- . . -- . Output_Top_Of_Page . SPEC & BODY -- . . -- .................................. procedure Output_Top_Of_Page ( Item : in File ) is --| Purpose --| This is an internal routine not specified in the package --| specification. Assuming that the output is at the top --| of page, it increments the Item.Page_Num, outputs --| the appropriate number of blank lines as per the Top_Margin, --| and outputs the header lines (distinguishing between even and --| odd pages). --| --| Exceptions (none) --| Notes (none) Is_Even : BOOLEAN; begin -- Output_Top_Of_Page Item.Line_Num := 1; if Item.Page_Attr(Top_Margin) > 0 then for I in 1 .. Item.Page_Attr(Top_Margin) loop FOF_Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; end if; if Item.Page_Attr(Header_Lines) > 0 then if Item.Page_Num / 2 * 2 = Item.Page_Num then Is_Even := true; else Is_Even := false; end if; for I in 1 .. Header_Footer_Line(Item.Page_Attr(Header_Lines)) loop if Is_Even then Put_Header_Footer_Line(Item, FOF_DYN.Str(Item.Even_Header(I, LEFT)), FOF_DYN.Str(Item.Even_Header(I, CENTER)), FOF_DYN.Str(Item.Even_Header(I, RIGHT)), Current_Page(Item)); else Put_Header_Footer_Line(Item, FOF_DYN.Str(Item.Odd_Header(I, LEFT)), FOF_DYN.Str(Item.Odd_Header(I, CENTER)), FOF_DYN.Str(Item.Odd_Header(I, RIGHT)), Current_Page(Item)); end if; end loop; end if; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Top); end Output_Top_Of_Page; -- .................................. -- . . -- . Output_Bottom_Of_Page . BODY -- . . -- .................................. procedure Output_Bottom_Of_Page ( Item : in File ) is --| Purpose --| Output_Bottom_Of_Page determines how many blank lines are left --| in the text area (between the top margin/header combination and --| the bottom margin/footer combination) and outputs blank lines in --| order to reach the first footer line. It then outputs the --| footer (distinguishing between even and odd page footers) and --| advances over the bottom margin (with either blank lines or --| form feeds). --| --| Exceptions (none) --| Notes (none) Lines_Left : Line_Number; Is_Even : BOOLEAN; begin -- Output_Bottom_Of_Page Lines_Left := Line_Number(Item.Page_Attr(Total_Lines) - (Item.Page_Attr(Bottom_Margin) + Item.Page_Attr(Footer_Lines))) - Item.Line_Num + 1; if Lines_Left < 0 then Lines_Left := 0; end if; if Lines_Left > 0 then for I in 1 .. Lines_Left loop FOF_Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; end if; if Item.Page_Attr(Footer_Lines) > 0 then if Item.Page_Num / 2 * 2 = Item.Page_Num then Is_Even := true; else Is_Even := false; end if; for I in 1 .. Header_Footer_Line(Item.Page_Attr(Footer_Lines)) loop if Is_Even then Put_Header_Footer_Line(Item, FOF_DYN.Str(Item.Even_Footer(I, LEFT)), FOF_DYN.Str(Item.Even_Footer(I, CENTER)), FOF_DYN.Str(Item.Even_Footer(I, RIGHT)), Current_Page(Item)); else Put_Header_Footer_Line(Item, FOF_DYN.Str(Item.Odd_Footer(I, LEFT)), FOF_DYN.Str(Item.Odd_Footer(I, CENTER)), FOF_DYN.Str(Item.Odd_Footer(I, RIGHT)), Current_Page(Item)); end if; end loop; end if; if Item.Page_Attr(Bottom_Margin) > 0 then if Item.Line_Attr(Use_Form_Feed) = On then FOF_Output_File.New_Page(Item.File_Id); else for I in 1 .. Item.Page_Attr(Bottom_Margin) loop FOF_Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; end if; end if; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Bottom); end Output_Bottom_Of_Page; -- .................................. -- . . -- . Simple_Break_Page . BODY -- . . -- .................................. procedure Simple_Break_Page ( Item : in File ) is --| Purpose --| Simple_Break_Page outputs to the bottom of the page and the --| top of the next page if paging is on. --| --| Exceptions (none) --| Notes (none) begin -- Simple_Break_Page if Item.Line_Attr(Paging) = On then Output_Bottom_Of_Page(Item); Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; end Simple_Break_Page; -- .................................. -- . . -- . Simple_Break_Page . SPEC & BODY -- . . -- .................................. procedure Simple_Break_Page ( Item : in File; New_Page_Num : in Page_Number ) is --| Purpose --| Simple_Break_Page outputs to the bottom of the page and the --| top of the next page if paging is on. It sets the number of --| the new page to New_Page_Num. --| --| Exceptions (none) --| Notes (none) begin -- Simple_Break_Page if Item.Line_Attr(Paging) = On then Output_Bottom_Of_Page(Item); Item.Page_Num := New_Page_Num; Output_Top_Of_Page(Item); else Item.Page_Num := New_Page_Num; Item.Line_Num := 1; end if; end Simple_Break_Page; -- .................................. -- . . -- . Open . BODY -- . . -- .................................. procedure Open ( Item : in out File; File_Name : in STRING; Result : out Status ) is --| Notes --| Open the output file object and set --| defaults. Map the FOF_Output_File.Open status to the --| Formatted_Output_File.Open status. Local_Result : Status; begin -- Open Item := new FILE_OBJECT; begin FOF_Output_File.Create(Item.File_Id, File_Name); Local_Result := Ok; exception when others => Local_Result := Not_Ok; end; if Local_Result = Ok then Item.Output_Is_Open := true; Item.Output_Is_Empty := true; Item.Line_Is_Empty := true; Item.Page_Attr := Page_Attribute_Defaults; Item.Line_Attr := Line_Attribute_Defaults; Item.Page_Num := 0; Item.Line_Num := 1; Item.Even_Header := Header_Footer_Default; Item.Odd_Header := Header_Footer_Default; Item.Even_Footer := Header_Footer_Default; Item.Odd_Footer := Header_Footer_Default; Item.Page_Number_Id := Page_Number_Id_Default; Item.Pn_Format := Arabic; Item.Pn_String := FOF_DYN.D_String(Page_Number_Id_Default); else Item.Output_Is_Open := false; end if; Result := Local_Result; end Open; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Item : in File ) is --| Notes (none) begin -- Close if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Line_Attr(Paging) = On then Break_Line(Item); Output_Bottom_Of_Page(Item); else Item.Line_Num := 1; end if; FOF_Output_File.Close(Item.File_Id); Item.Output_Is_Open := false; end Close; -- .................................. -- . . -- . Put_Invisible_Word . BODY -- . . -- .................................. procedure Put_Invisible_Word ( Item : in File; What : in STRING ) is --| Notes (none) begin -- Put_Invisible_Word if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; if Item.Line_Is_Empty then Start_Line(Item); end if; Item.Current_Line(Item.Index .. Item.Index + What'Length - 1) := What; Item.Index := Item.Index + What'Length; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Put_Invisible); end Put_Invisible_Word; -- .................................. -- . . -- . Put_Word . BODY -- . . -- .................................. procedure Put_Word ( Item : in File; What : in STRING ) is --| Notes (none) Adjustment_Length : NATURAL; Adjustment_String : constant STRING -- 2 spaces := " "; -- .................................. -- . . -- . Put_Word.Put_What . SPEC & BODY -- . . -- .................................. procedure Put_What is --| Notes --| Put_What is used to place the What string into Item.Current_Line --| and update the other variables as necessary. Full_Adjustment_Length : NATURAL := Adjustment_Length + What'Length; Full_String_Length : NATURAL := Item.Char_Count + Full_Adjustment_Length; Lower_Index : NATURAL := Item.Index; Upper_Index : NATURAL := Item.Index + Full_Adjustment_Length - 1; begin -- Put_What Item.Current_Line(Lower_Index .. Upper_Index) := Adjustment_String(1 .. Adjustment_Length) & What; Item.Index := Upper_Index + 1; Item.Char_Count := Full_String_Length; Item.Last_Char := Item.Current_Line(Item.Index - 1); if Item.Line_Attr(Underline) = On then for I in 1 .. What'Length loop Item.Current_Line(Item.Index) := Ascii.Bs; Item.Index := Item.Index + 1; end loop; for I in What'range loop if Item.Line_Attr(Underline_Punct) = Off then if Is_Punctuation(What(I)) then Item.Current_Line(Item.Index) := What(I); else Item.Current_Line(Item.Index) := '_'; end if; else Item.Current_Line(Item.Index) := '_'; end if; Item.Index := Item.Index + 1; end loop; end if; if Item.Line_Attr(Bold) = On then for I in 1 .. What'Length loop Item.Current_Line(Item.Index) := Ascii.Bs; Item.Index := Item.Index + 1; end loop; for I in What'range loop Item.Current_Line(Item.Index) := What(I); Item.Index := Item.Index + 1; end loop; end if; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Put_What); end Put_What; begin -- Put_Word if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; if Item.Line_Is_Empty then Adjustment_Length := 0; else case Item.Last_Char is when ' ' => Adjustment_Length := 0; when '.' => Adjustment_Length := 2; when others => Adjustment_Length := 1; end case; end if; if Item.Line_Attr(Fill) = On then if Item.Char_Count + Adjustment_Length + What'Length <= Item.Page_Attr(Right_Margin) - Item.Page_Attr(Right_Indent) + Item.Page_Attr(Page_Offset) then -- FILL is on and there is enough room on the line if Item.Line_Is_Empty then Start_Line(Item); end if; Put_What; else -- FILL is on, but not enough room on line if Item.Line_Attr(Justify) = On and not Item.Line_Is_Empty then Justify_Line(Item); end if; Break_Line(Item); Start_Line(Item); Adjustment_Length := 0; Put_What; end if; else -- No FILL, so no JUSTIFY either if Item.Line_Is_Empty then Start_Line(Item); end if; Put_What; end if; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Put_Word); end Put_Word; -- .................................. -- . . -- . Put_Line . BODY -- . . -- .................................. procedure Put_Line ( Item : in File; What : in STRING ) is --| Notes (none) First : NATURAL; Last : NATURAL; Temp : NATURAL; type PARSE_STATE is ( IN_WHITE_SPACE, IN_TEXT ); Current_State : PARSE_STATE; begin -- Put_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; if Item.Line_Attr(Fill) = Off then -- No FILL, so break previous line and output as a line Break_Line(Item); Conditional_Break_Page(Item); Start_Line(Item); -- for margin settings Item.Line_Is_Empty := true; if Item.Line_Attr(CENTER) = On then Temp := (Item.Page_Attr(Right_Margin) - Item.Page_Attr(Right_Indent)) - (Item.Page_Attr(Left_Margin) + Item.Page_Attr(Left_Indent)) + 1; if Temp > What'Length then Temp := (Temp - What'Length) / 2; for I in 1 .. Temp loop FOF_Output_File.Put(Item.File_Id, ' '); end loop; end if; end if; FOF_Output_File.Put(Item.File_Id, Item.Current_Line(1 .. Item.Char_Count) & What); if Item.Line_Attr(Bold) = On then for I in 1 .. What'Length loop FOF_Output_File.Put(Item.File_Id, Ascii.Bs); end loop; for I in What'range loop FOF_Output_File.Put(Item.File_Id, What(I)); end loop; end if; if Item.Line_Attr(Underline) = On then for I in 1 .. What'Length loop FOF_Output_File.Put(Item.File_Id, Ascii.Bs); end loop; for I in What'range loop if What(I) > ' ' then if Item.Line_Attr(Underline_Punct) = Off then if Is_Punctuation(What(I)) then FOF_Output_File.Put(Item.File_Id, What(I)); else FOF_Output_File.Put(Item.File_Id, '_'); end if; else FOF_Output_File.Put(Item.File_Id, '_'); end if; else FOF_Output_File.Put(Item.File_Id, What(I)); end if; end loop; end if; FOF_Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; Space_Lines(Item); else -- FILL, so parse out each word and use Put_Word to output Current_State := IN_WHITE_SPACE; for I in What'First .. What'Last loop case Current_State is when IN_WHITE_SPACE => if What(I) > ' ' then First := I; Current_State := IN_TEXT; end if; when IN_TEXT => if What(I) <= ' ' then Last := I - 1; Put_Word(Item, What(First .. Last)); Current_State := IN_WHITE_SPACE; end if; end case; end loop; if Current_State = IN_TEXT then Last := What'Last; Put_Word(Item, What(First .. Last)); end if; end if; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Put_Line); end Put_Line; -- .................................. -- . . -- . Break_Line . BODY -- . . -- .................................. procedure Break_Line ( Item : in File ) is --| Notes --| Break_Line checks to see if the Current_Line is empty, and, --| if not, outputs it and sets the empty flag to TRUE. Page --| breaks are also handled if necessary. begin -- Break_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; if not Item.Line_Is_Empty then Conditional_Break_Page(Item); FOF_Output_File.Put_Line(Item.File_Id, Item.Current_Line(1 .. Item.Index - 1)); Item.Line_Num := Item.Line_Num + 1; Space_Lines(Item); Item.Line_Is_Empty := true; end if; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Break_Line); end Break_Line; -- .................................. -- . . -- . Current_Line . BODY -- . . -- .................................. function Current_Line ( Item : in File ) return Line_Number is --| Notes (none) begin -- Current_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Line_Num; end Current_Line; -- .................................. -- . . -- . Skip . BODY -- . . -- .................................. procedure Skip ( Item : in File; Number_Of_Lines : in Line_Number := 1 ) is --| Notes (none) begin -- Skip if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; Break_Line(Item); if Test_Page(Item, Number_Of_Lines + Number_Of_Lines * Line_Number(Item.Page_Attr(Line_Spacing))) then for I in 1 .. Number_Of_Lines loop FOF_Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; Space_Lines(Item); end loop; else Simple_Break_Page(Item); end if; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Skip); end Skip; -- .................................. -- . . -- . Break_Page . BODY -- . . -- .................................. procedure Break_Page ( Item : in File ) is --| Notes --| Issues blank lines for the rest of the text area, outputs footer --| and bottom margin, and outputs header for next page. begin -- Break_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; Break_Line(Item); Simple_Break_Page(Item); exception when others => FOF_Error_Log.Write_Error(Error_Internal_Break_Page_1); end Break_Page; -- .................................. -- . . -- . Break_Page . BODY -- . . -- .................................. procedure Break_Page ( Item : in File; New_Page_Num : in Page_Number ) is --| Notes (none) begin -- Break_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; Break_Line(Item); Simple_Break_Page(Item, New_Page_Num); exception when others => FOF_Error_Log.Write_Error(Error_Internal_Break_Page_2); end Break_Page; -- .................................. -- . . -- . Current_Page . BODY -- . . -- .................................. function Current_Page ( Item : in File ) return Page_Number is --| Notes (none) begin -- Current_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Page_Num; end Current_Page; -- .................................. -- . . -- . Current_Page . BODY -- . . -- .................................. function Current_Page ( Item : in FILE ) return STRING is --| Notes (none) -- .................................. -- . . -- . Current_Page.Convert . SPEC & BODY -- . . -- .................................. function Convert ( Page_Number : in STRING ) return STRING is Result : STRING(1..80); Last : NATURAL := 0; -- .................................. -- . . -- . Current_Page.Convert.Enter . SPEC & BODY -- . . -- .................................. procedure Enter ( Item : in STRING ) is Start : NATURAL := Item'First; begin -- Enter if Item(Start) = ' ' then Start := Start + 1; end if; for I in Start .. Item'Last loop Last := Last + 1; Result(Last) := Item(I); end loop; end Enter; begin -- Convert for I in Page_Number'Range loop if Page_Number(I) /= Item.Page_Number_Id then Last := Last + 1; Result(Last) := Page_Number(I); else Enter(Pnum_As_String(Item.Page_Num, Item.Pn_Format)); end if; end loop; return Result(1..Last); end Convert; begin -- Current_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; return Convert(FOF_DYN.Str(Item.Pn_String)); end Current_Page; -- .................................. -- . . -- . Set_Page_Number_Format . BODY -- . . -- .................................. procedure Set_Page_Number_Format ( Item : in File; To : in NUMERIC_FORMAT; Format_String : in STRING ) is --| Notes (none) begin -- Set_Page_Number_Format if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Pn_Format := To; if Format_String'Length > 0 then FOF_DYN.Clear(Item.Pn_String); Item.Pn_String := FOF_DYN.D_String(Format_String); end if; end Set_Page_Number_Format; -- .................................. -- . . -- . Set_Page_Attribute . BODY -- . . -- .................................. procedure Set_Page_Attribute ( Item : in File; What : in Page_Attribute; To : in NATURAL ) is --| Notes (none) begin -- Set_Page_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Page_Attr(What) := To; end Set_Page_Attribute; -- .................................. -- . . -- . Set_Line_Attribute . BODY -- . . -- .................................. procedure Set_Line_Attribute ( Item : in File; What : in Line_Attribute; To : in Off_On ) is --| Notes (none) begin -- Set_Line_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Line_Attr(What) := To; if What = CENTER then if To = On then Item.Line_Attr(Fill_State_Before_Center) := Item.Line_Attr(Fill); Item.Line_Attr(Fill) := Off; else Item.Line_Attr(Fill) := Item.Line_Attr(Fill_State_Before_Center); end if; end if; end Set_Line_Attribute; -- .................................. -- . . -- . Get_Page_Attribute . BODY -- . . -- .................................. function Get_Page_Attribute ( Item : in File; What : in Page_Attribute ) return NATURAL is --| Notes (none) begin -- Get_Page_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Page_Attr(What); end Get_Page_Attribute; -- .................................. -- . . -- . Get_Line_Attribute . BODY -- . . -- .................................. function Get_Line_Attribute ( Item : in File; What : in Line_Attribute ) return Off_On is --| Notes (none) begin -- Get_Line_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Line_Attr(What); end Get_Line_Attribute; -- .................................. -- . . -- . Test_Page . BODY -- . . -- .................................. function Test_Page ( Item : in File; Number_Of_Lines : in Line_Number ) return BOOLEAN is --| Notes (none) begin -- Test_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; return INTEGER(Number_Of_Lines) <= Item.Page_Attr(Total_Lines) - (Item. Page_Attr(Bottom_Margin) + Item.Page_Attr(Footer_Lines)) - INTEGER(Item.Line_Num); end Test_Page; -- .................................. -- . . -- . Set_Footer_Line . BODY -- . . -- .................................. procedure Set_Footer_Line ( Item : in File; Class : in Page_Kind; Number : in Header_Footer_Line; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING ) is --| Notes (none) begin -- Set_Footer_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; case Class is when Even_Pages => FOF_DYN.Clear(Item.Even_Footer(Number, LEFT)); Item.Even_Footer(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Even_Footer(Number, CENTER)); Item.Even_Footer(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Even_Footer(Number, RIGHT)); Item.Even_Footer(Number, RIGHT) := FOF_DYN.D_String(Right_Text); when Odd_Pages => FOF_DYN.Clear(Item.Odd_Footer(Number, LEFT)); Item.Odd_Footer(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Odd_Footer(Number, CENTER)); Item.Odd_Footer(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Odd_Footer(Number, RIGHT)); Item.Odd_Footer(Number, RIGHT) := FOF_DYN.D_String(Right_Text); when All_Pages => FOF_DYN.Clear(Item.Even_Footer(Number, LEFT)); Item.Even_Footer(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Even_Footer(Number, CENTER)); Item.Even_Footer(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Even_Footer(Number, RIGHT)); Item.Even_Footer(Number, RIGHT) := FOF_DYN.D_String(Right_Text); FOF_DYN.Clear(Item.Odd_Footer(Number, LEFT)); Item.Odd_Footer(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Odd_Footer(Number, CENTER)); Item.Odd_Footer(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Odd_Footer(Number, RIGHT)); Item.Odd_Footer(Number, RIGHT) := FOF_DYN.D_String(Right_Text); end case; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Set_Footer_Line); end Set_Footer_Line; -- .................................. -- . . -- . Set_Header_Line . BODY -- . . -- .................................. procedure Set_Header_Line ( Item : in File; Class : in Page_Kind; Number : in Header_Footer_Line; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING ) is --| Notes (none) begin -- Set_Header_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; case Class is when Even_Pages => FOF_DYN.Clear(Item.Even_Header(Number, LEFT)); Item.Even_Header(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Even_Header(Number, CENTER)); Item.Even_Header(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Even_Header(Number, RIGHT)); Item.Even_Header(Number, RIGHT) := FOF_DYN.D_String(Right_Text); when Odd_Pages => FOF_DYN.Clear(Item.Odd_Header(Number, LEFT)); Item.Odd_Header(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Odd_Header(Number, CENTER)); Item.Odd_Header(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Odd_Header(Number, RIGHT)); Item.Odd_Header(Number, RIGHT) := FOF_DYN.D_String(Right_Text); when All_Pages => FOF_DYN.Clear(Item.Even_Header(Number, LEFT)); Item.Even_Header(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Even_Header(Number, CENTER)); Item.Even_Header(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Even_Header(Number, RIGHT)); Item.Even_Header(Number, RIGHT) := FOF_DYN.D_String(Right_Text); FOF_DYN.Clear(Item.Odd_Header(Number, LEFT)); Item.Odd_Header(Number, LEFT) := FOF_DYN.D_String(Left_Text); FOF_DYN.Clear(Item.Odd_Header(Number, CENTER)); Item.Odd_Header(Number, CENTER) := FOF_DYN.D_String(Center_Text); FOF_DYN.Clear(Item.Odd_Header(Number, RIGHT)); Item.Odd_Header(Number, RIGHT) := FOF_DYN.D_String(Right_Text); end case; exception when others => FOF_Error_Log.Write_Error(Error_Internal_Set_Header_Line); end Set_Header_Line; -- .................................. -- . . -- . Set_Page_Number_Id . BODY -- . . -- .................................. procedure Set_Page_Number_Id ( Item : in File; To : in CHARACTER ) is --| Notes (none) begin -- Set_Page_Number_Id if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Page_Number_Id := To; end Set_Page_Number_Id; -- .................................. -- . . -- . Set_Page_Number_Format . BODY -- . . -- .................................. procedure Set_Page_Number_Format ( Item : in File; To : in Numeric_Format ) is --| Notes (none) begin -- Set_Page_Number_Format if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Pn_Format := To; end Set_Page_Number_Format; -- .................................. -- . . -- . Page_Number_Format . BODY -- . . -- .................................. function Page_Number_Format ( Item : in FILE ) return NUMERIC_FORMAT is --| Notes (none) begin -- Page_Number_Format if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Pn_Format; end Page_Number_Format; end Formatted_Output_File; --:::::::::: --hashfcns.bdy --:::::::::: with unchecked_conversion; package body hashing_functions_pkg is function hash_string(s: string) return natural is type word is array(1..32) of boolean; function word_to_int is new unchecked_conversion(source => word, target => integer); chars_per_word: constant := 4; subtype word_str is string(1..chars_per_word); function word_str_to_word is new unchecked_conversion(source => word_str, target => word); words_in_s: natural; left_over: natural; hash_word: word := (word'range => false); hack_word_str: word_str; --Decbug hack_word: word; --Decbug result1: integer; --Decbug result2: natural; --Decbug begin words_in_s := s'length/chars_per_word; left_over := s'length mod chars_per_word; --Decbugs replacement: for i in 1..words_in_s loop hack_word_str := s(s'first + chars_per_word * (i - 1) .. s'first + chars_per_word * i - 1); hack_word := word_str_to_word(hack_word_str); hash_word := hash_word xor hack_word; -- hash_word := -- hash_word xor -- word_str_to_word(s(s'first + chars_per_word * (i - 1) .. -- s'first + chars_per_word * i - 1)); end loop; -- Decbug Replacements: hack_word_str(1..left_over) := s(s'first + chars_per_word * words_in_s .. s'last); hack_word := word_str_to_word(hack_word_str); hash_word(1..left_over) := hash_word(1..left_over) xor hack_word(1..left_over); -- hash_word(1..left_over) := -- hash_word(1..left_over) xor -- word_str_to_word(s(s'first + chars_per_word * words_in_s..s'last)); result1 := word_to_int(hash_word); result2 := result1 mod prime_num; return result2; -- return word_to_int(hash_word) mod prime_num; end hash_string; end hashing_functions_pkg; --:::::::::: --in.bdy --:::::::::: -- ********************************** -- * * -- * Input_File * BODY -- * * -- ********************************** with Text_IO; package body Input_File is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version type FILE_OBJECT is record Is_Open : BOOLEAN := false; File : Text_IO.File_Type; end record; -- .................................. -- . . -- . Open . BODY -- . . -- .................................. procedure Open ( Id : in out File_Type; File_Name : in STRING ) is --| Notes (none) begin -- Open Id := new FILE_OBJECT; Text_IO.Open(Id.File, Text_IO.In_File, File_Name); Id.Is_Open := true; exception -- Open -- Open when others => raise Cannot_Open_Input_File; end Open; -- .................................. -- . . -- . Get_Line . BODY -- . . -- .................................. procedure Get_Line ( Id : in out File_Type; Item : out STRING; Last : out NATURAL ) is --| Notes (none) begin -- Get_Line if Id.Is_Open then Text_IO.Get_Line(Id.File, Item, Last); end if; exception -- Get_Line -- Get_Line when others => raise Read_Error; end Get_Line; -- .................................. -- . . -- . End_Of_File . BODY -- . . -- .................................. function End_Of_File ( Id : in File_Type ) return BOOLEAN is --| Notes (none) begin -- End_Of_File if Id.Is_Open then return Text_IO.End_Of_File(Id.File); end if; exception -- End_Of_File -- End_Of_File when others => raise Read_Error; end End_Of_File; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Id : in out File_Type ) is --| Notes (none) begin -- Close if Id.Is_Open then Text_IO.Close(Id.File); end if; end Close; end Input_File; --:::::::::: --lists.bdy --:::::::::: with unchecked_deallocation; package body Lists is procedure Free is new unchecked_deallocation (Cell, List); -------------------------------------------------------------------------- function Last (L: in List) return List is Place_In_L: List; Temp_Place_In_L: List; --| Link down the list L and return the pointer to the last element --| of L. If L is null raise the EmptyList exception. begin if L = null then raise EmptyList; else --| Link down L saving the pointer to the previous element in --| Temp_Place_In_L. After the last iteration Temp_Place_In_L --| points to the last element in the list. Place_In_L := L; while Place_In_L /= null loop Temp_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end loop; return Temp_Place_In_L; end if; end Last; -------------------------------------------------------------------------- procedure Attach (List1: in out List; List2: in List ) is EndOfList1: List; --| Attach List2 to List1. --| If List1 is null return List2 --| If List1 equals List2 then raise CircularList --| Otherwise get the pointer to the last element of List1 and change --| its Next field to be List2. begin if List1 = null then List1 := List2; return; elsif List1 = List2 then raise CircularList; else EndOfList1 := Last (List1); EndOfList1.Next := List2; end if; end Attach; -------------------------------------------------------------------------- procedure Attach (L: in out List; Element: in ItemType ) is NewEnd: List; --| Create a list containing Element and attach it to the end of L begin NewEnd := new Cell'(Info => Element, Next => null); Attach (L, NewEnd); end; -------------------------------------------------------------------------- function Attach (Element1: in ItemType; Element2: in ItemType ) return List is NewList: List; --| Create a new list containing the information in Element1 and --| attach Element2 to that list. begin NewList := new Cell'(Info => Element1, Next => null); Attach (NewList, Element2); return NewList; end; -------------------------------------------------------------------------- procedure Attach (Element: in ItemType; L: in out List ) is --| Create a new cell whose information is Element and whose Next --| field is the list L. This prepends Element to the List L. begin L := new Cell'(Info => Element, Next => L); end; -------------------------------------------------------------------------- function Attach ( List1: in List; List2: in List ) return List is Last_Of_List1: List; begin if List1 = null then return List2; elsif List1 = List2 then raise CircularList; else Last_Of_List1 := Last (List1); Last_Of_List1.Next := List2; return List1; end if; end Attach; ------------------------------------------------------------------------- function Attach( L: in List; Element: in ItemType ) return List is NewEnd: List; Last_Of_L: List; --| Create a list called NewEnd and attach it to the end of L. --| If L is null return NewEnd --| Otherwise get the last element in L and make its Next field --| NewEnd. begin NewEnd := new Cell'(Info => Element, Next => null); if L = null then return NewEnd; else Last_Of_L := Last (L); Last_Of_L.Next := NewEnd; return L; end if; end Attach; -------------------------------------------------------------------------- function Attach (Element: in ItemType; L: in List ) return List is begin return (new Cell'(Info => Element, Next => L)); end Attach; --------------------------------------------------------------------------- function Copy (L: in List) return List is --| If L is null return null --| Otherwise recursively copy the list by first copying the information --| at the head of the list and then making the Next field point to --| a copy of the tail of the list. begin if L = null then return null; else return new Cell'(Info => L.Info, Next => Copy (L.Next)); end if; end Copy; -------------------------------------------------------------------------- function CopyDeep (L: in List) return List is --| If L is null then return null. --| Otherwise copy the first element of the list into the head of the --| new list and copy the tail of the list recursively using CopyDeep. begin if L = null then return null; else return new Cell'( Info => Copy (L.Info), Next => CopyDeep(L.Next)); end if; end CopyDeep; -------------------------------------------------------------------------- function Create return List is --| Return the empty list. begin return null; end Create; -------------------------------------------------------------------------- procedure DeleteHead (L: in out List) is TempList: List; --| Remove the element of the head of the list and return it to the heap. --| If L is null EmptyList. --| Otherwise save the Next field of the first element, remove the first --| element and then assign to L the Next field of the first element. begin if L = null then raise EmptyList; else TempList := L.Next; Free (L); L := TempList; end if; end DeleteHead; -------------------------------------------------------------------------- function DeleteItem( --| remove the first occurrence of Element --| from L L: in List; --| list element is being removed from Element: in ItemType --| element being removed ) return List is I :List; Result :List; Found :boolean := false; begin --| ALGORITHM --| Attach all elements of L to Result except the first element in L --| whose value is Element. If the current element pointed to by I --| is not equal to element or the element being skipped was found --| then attach the current element to Result. I := L; while (I /= null) loop if (not Equal (I.Info, Element)) or (Found) then Attach (Result, I.Info); else Found := true; end if; I := I.Next; end loop; return Result; end DeleteItem; ------------------------------------------------------------------------------ function DeleteItems ( --| remove all occurrences of Element --| from L. L: in List; --| The List element is being removed from Element: in ItemType --| element being removed ) return List is I :List; Result :List; begin --| ALGORITHM --| Walk over the list L and if the current element does not equal --| Element then attach it to the list to be returned. I := L; while I /= null loop if not Equal (I.Info, Element) then Attach (Result, I.Info); end if; I := I.Next; end loop; return Result; end DeleteItems; ------------------------------------------------------------------------------- procedure DeleteItem (L: in out List; Element: in ItemType ) is Temp_L :List; --| Remove the first element in the list with the value Element. --| If the first element of the list is equal to element then --| remove it. Otherwise, recurse on the tail of the list. begin if Equal(L.Info, Element) then DeleteHead(L); else DeleteItem(L.Next, Element); end if; end DeleteItem; -------------------------------------------------------------------------- procedure DeleteItems (L: in out List; Element: in ItemType ) is Place_In_L :List; --| Current place in L. Last_Place_In_L :List; --| Last place in L. Temp_Place_In_L :List; --| Holds a place in L to be removed. --| Walk over the list removing all elements with the value Element. begin Place_In_L := L; Last_Place_In_L := null; while (Place_In_L /= null) loop --| Found an element equal to Element if Equal(Place_In_L.Info, Element) then --| If Last_Place_In_L is null then we are at first element --| in L. if Last_Place_In_L = null then Temp_Place_In_L := Place_In_L; L := Place_In_L.Next; else Temp_Place_In_L := Place_In_L; --| Relink the list Last's Next gets Place's Next Last_Place_In_L.Next := Place_In_L.Next; end if; --| Move Place_In_L to the next position in the list. --| Free the element. --| Do not update the last element in the list it remains the --| same. Place_In_L := Place_In_L.Next; Free (Temp_Place_In_L); else --| Update the last place in L and the place in L. Last_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end if; end loop; --| If we have not found an element raise an exception. end DeleteItems; ------------------------------------------------------------------------------ procedure Destroy (L: in out List) is Place_In_L: List; HoldPlace: List; --| Walk down the list removing all the elements and set the list to --| the empty list. begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Free (HoldPlace); end loop; L := null; end Destroy; -------------------------------------------------------------------------- procedure DestroyDeep (L: in out List) is Place_In_L: List; HoldPlace: List; --| Walk down the list removing all the elements and set the list to --| the empty list. begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Dispose (HoldPlace.Info); Free (HoldPlace); end loop; L := null; end DestroyDeep; -------------------------------------------------------------------------- function FirstValue (L: in List) return ItemType is --| Return the first value in the list. begin if L = null then raise EmptyList; else return (L.Info); end if; end FirstValue; -------------------------------------------------------------------------- procedure Forward (I: in out ListIter) is --| Return the pointer to the next member of the list. begin if I = null then raise NoMore; else I := ListIter (I.Next); end if; end Forward; -------------------------------------------------------------------------- function IsInList (L: in List; Element: in ItemType ) return boolean is Place_In_L: List; --| Check if Element is in L. If it is return true otherwise return false. begin Place_In_L := L; while Place_In_L /= null loop if Equal(Place_In_L.Info, Element) then return true; end if; Place_In_L := Place_In_L.Next; end loop; return false; end IsInList; -------------------------------------------------------------------------- function IsEmpty (L: in List) return boolean is --| Is the list L empty. begin return (L = null); end IsEmpty; -------------------------------------------------------------------------- function LastValue (L: in List) return ItemType is LastElement: List; --| Return the value of the last element of the list. Get the pointer --| to the last element of L and then return its information. begin LastElement := Last (L); return LastElement.Info; end LastValue; -------------------------------------------------------------------------- function Length (L: in List) return integer is --| Recursively compute the length of L. The length of a list is --| 0 if it is null or 1 + the length of the tail. begin if L = null then return (0); else return (1 + Length (Tail (L))); end if; end Length; -------------------------------------------------------------------------- function MakeList ( E :in ItemType ) return List is begin return new Cell ' (Info => E, Next => null); end; -------------------------------------------------------------------------- function MakeListIter (L: in List) return ListIter is --| Start an iteration operation on the list L. Do a type conversion --| from List to ListIter. begin return ListIter (L); end MakeListIter; -------------------------------------------------------------------------- function More (L: in ListIter) return boolean is --| This is a test to see whether an iteration is complete. begin return L /= null; end; -------------------------------------------------------------------------- procedure Next (Place: in out ListIter; Info: out ItemType ) is PlaceInList: List; --| This procedure gets the information at the current place in the List --| and moves the ListIter to the next postion in the list. --| If we are at the end of a list then exception NoMore is raised. begin if Place = null then raise NoMore; else PlaceInList := List(Place); Info := PlaceInList.Info; Place := ListIter(PlaceInList.Next); end if; end Next; -------------------------------------------------------------------------- procedure ReplaceHead (L: in out List; Info: in ItemType ) is --| This procedure replaces the information at the head of a list --| with the given information. If the list is empty the exception --| EmptyList is raised. begin if L = null then raise EmptyList; else L.Info := Info; end if; end ReplaceHead; -------------------------------------------------------------------------- procedure ReplaceTail (L: in out List; NewTail: in List ) is Temp_L: List; --| This destroys the tail of a list and replaces the tail with --| NewTail. If L is empty EmptyList is raised. begin Destroy(L.Next); L.Next := NewTail; exception when constraint_error => raise EmptyList; end ReplaceTail; -------------------------------------------------------------------------- function Tail (L: in List) return List is --| This returns the list which is the tail of L. If L is null --| EmptyList is raised. begin if L = null then raise EmptyList; else return L.Next; end if; end Tail; -------------------------------------------------------------------------- function CellValue ( I :in ListIter ) return ItemType is L :List; begin -- Convert I to a List type and then return the value it points to. L := List(I); return L.Info; end CellValue; -------------------------------------------------------------------------- function Equal (List1: in List; List2: in List ) return boolean is PlaceInList1: List; PlaceInList2: LIst; Contents1: ItemType; Contents2: ItemType; --| This function tests to see if two lists are equal. Two lists --| are equal if for all the elements of List1 the corresponding --| element of List2 has the same value. Thus if the 1st elements --| are equal and the second elements are equal and so up to n. --| Thus a necessary condition for two lists to be equal is that --| they have the same number of elements. --| This function walks over the two list and checks that the --| corresponding elements are equal. As soon as we reach --| the end of a list (PlaceInList = null) we fall out of the loop. --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop --| then the lists are equal. If they both are not null the lists aren't --| equal. Note that equality on elements is based on a user supplied --| function Equal which is used to test for item equality. begin PlaceInList1 := List1; PlaceInList2 := List2; while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop if not Equal (PlaceInList1.Info, PlaceInList2.Info) then return false; end if; PlaceInList1 := PlaceInList1.Next; PlaceInList2 := PlaceInList2.Next; end loop; return ((PlaceInList1 = null) and (PlaceInList2 = null) ); end Equal; end Lists; -------------------------------------------------------------------------- --:::::::::: --logical.bdy --:::::::::: package body logical is -- These functions work on all two's complement machines -- where -integer'last-1 = integer'first two_to_the_i : array(integer(0)..integer(integer'size-1)) of integer; --Utility function to rotate left function rotate(arg, count : integer) return integer is result : integer := arg; big : CONSTANT integer := integer'last/2+1; c : integer := count; begin if c < 0 then c := integer'size + c; end if; for i in 1..(c MOD integer'size) loop if result < 0 then -- -16#80000000#..-1 result := result + big; if result >= 0 then result := result * 2 - integer'last; else result := (result + big) * 2 + 1; end if; elsif result < big then -- 0 .. 16#3FFFFFFF# result := result * 2; else -- 16#40000000#..16#7FFFFFFF# result := (result - big) * 2 - integer'last; result := result - 1; end if; end loop; return result; end rotate; -- --Utility function to logical shift function shift(arg, count : integer) return integer is result : integer := arg; big : CONSTANT integer := integer'last/2+1; c : integer; begin -- shift if count < 0 then --shift to the right c := -count; if c >= integer'size then return 0; end if; if result >= 0 then result := result / two_to_the_i(c); else result := result + integer'last; result := (result + 1) / two_to_the_i(c) + big / two_to_the_i(c - 1); end if; elsif count > 0 then --shift to the left if count >= integer'size then return 0; end if; for i in 1..count loop if result < 0 then --top bit gets shifted out result := result + integer'last; result := result + 1; end if; if result >= big then result := ((result - big) * 2 - integer'last); result := result - 1; else result := result * 2; end if; end loop; end if; return result; end shift; -- --Utility function to logical shift right 1 function shift_right_1(arg : integer) return integer is result : integer := arg; big : CONSTANT integer := integer'last/2+1; begin -- shift_right_1 if result >= 0 then result := result / 2; else result := result + integer'last; result := (result + 1) / 2 + big; end if; return result; end shift_right_1; -- --Utility function to exclusive or function "xor"(left, right : integer) return integer is result : integer := 0; a1 : integer := left; a2 : integer := right; begin -- "xor" for i in integer(0)..integer'size-1 loop result := shift_right_1(result); if a1 MOD 2 /= a2 MOD 2 then result := result - integer'last; result := result - 1; end if; a1 := shift_right_1(a1); a2 := shift_right_1(a2); end loop; return result; end "xor"; -- --Utility function to and function "and"(left, right : integer) return integer is result : integer := 0; a1 : integer := left; a2 : integer := right; begin -- "and" for i in integer(0)..integer'size-1 loop result := shift_right_1(result); if (a1 MOD 2) + (a2 MOD 2) = 2 then result := result - integer'last; result := result - 1; end if; a1 := shift_right_1(a1); a2 := shift_right_1(a2); end loop; return result; end "and"; -- --Utility function to or function "or"(left, right : integer) return integer is result : integer := 0; a1 : integer := left; a2 : integer := right; begin -- "or" for i in integer(0)..integer'size-1 loop result := shift_right_1(result); if (a1 MOD 2) + (a2 MOD 2) /= 0 then result := result - integer'last; result := result - 1; end if; a1 := shift_right_1(a1); a2 := shift_right_1(a2); end loop; return result; end "or"; -- function "not"(right : integer) return integer is begin if right /= integer'first and then right /= integer'first + 1 then return (-1)-right; else return -(right + 1); end if; end "not"; -- begin for i in two_to_the_i'first..two_to_the_i'last-1 loop two_to_the_i(i) := 2**i; end loop; two_to_the_i(two_to_the_i'last) := (-2)**two_to_the_i'last; end logical; --:::::::::: --lparse.bdy --:::::::::: package body LINE_PARSER is LOCAL_ARGC : NATURAL := 0; -- Number of tokens package STRING_LIST is NUMBER_OF_STRINGS : NATURAL := 0; procedure RESET; procedure ADD_TO_LIST (ITEM : in STRING); function GET_FROM_LIST (ITEM : in NATURAL) return STRING; end STRING_LIST; package body STRING_LIST is type DYNAMIC_STRING_OBJECT (LENGTH : NATURAL); type DYNAMIC_STRING is access DYNAMIC_STRING_OBJECT; type DYNAMIC_STRING_OBJECT (LENGTH : NATURAL) is record DS : STRING (1 .. LENGTH); NEXT : DYNAMIC_STRING; end record; FIRST : DYNAMIC_STRING := null; LAST : DYNAMIC_STRING := null; procedure RESET is --========================= PDL =========================== --|ABSTRACT: --| RESET initializes the list. --|DESIGN DESCRIPTION: --| Set FIRST to NULL --| Set LAST to NULL --| Set NUMBER_OF_STRINGS to 0 --========================================================= begin FIRST := null; LAST := null; NUMBER_OF_STRINGS := 0; end RESET; procedure ADD_TO_LIST (ITEM : in STRING) is --========================= PDL =========================== --|ABSTRACT: --| ADD_TO_LIST adds the ITEM string to the linked list --| of dynamic strings implemented by this package. --|DESIGN DESCRIPTION: --| Create new DYNAMIC_STRING_OBJECT of the proper length --| Set DS field of new object to the ITEM string --| Set the NEXT field of the new object to NULL --| If FIRST pointer is null --| Set FIRST and LAST to point to the new object --| Else --| Set LAST.NEXT to point to the new object --| Set LAST to point to the new object --| End if --| Increment NUMBER_OF_STRINGS --========================================================= TEMP : DYNAMIC_STRING; begin TEMP := new DYNAMIC_STRING_OBJECT (ITEM'LENGTH); TEMP.DS (1 .. ITEM'LENGTH) := ITEM; TEMP.NEXT := null; if FIRST = null then FIRST := TEMP; LAST := TEMP; else LAST.NEXT := TEMP; LAST := TEMP; end if; NUMBER_OF_STRINGS := NUMBER_OF_STRINGS + 1; end ADD_TO_LIST; function GET_FROM_LIST (ITEM : in NATURAL) return STRING is --========================= PDL =========================== --|ABSTRACT: --| GET_FROM_LIST returns the ITEM string from the linked list --| of dynamic strings implemented by this package. --|DESIGN DESCRIPTION: --| If ITEM > 0 --| Advance to desired item --| End If --| Return the DS field of the desired item --========================================================= ROVER : DYNAMIC_STRING := FIRST; begin if ITEM > 0 then for I in 1 .. ITEM loop ROVER := ROVER.NEXT; end loop; end if; return ROVER.DS; end GET_FROM_LIST; end STRING_LIST; procedure INITIALIZE (ITEM : in STRING) is --========================= PDL =========================== --|ABSTRACT: --| INITIALIZE parses the string ITEM and sets up the --| internal variables and linked list. --|DESIGN DESCRIPTION: --| Reset the STRING_LIST Package --| Set CURRENT_STATE to LOOKING_FOR_TOKEN --| Over number of characters in line, loop --| Case CURRENT_STATE --| When LOOKING_FOR_TOKEN --| If character is not white-space --| Set CURRENT_STATE to IN_TOKEN --| If character is quote (") --| Set QUOTED to TRUE --| Set START to the character's index + 1 --| Else --| Set QUOTED to FALSE --| Set START to the character's index --| End IF --| End If --| When IN_TOKEN --| If QUOTED --| If character is quote (") --| Set STOP to the previous character's index --| Add slice from START to STOP to list --| Set CURRENT_STATE to LOOKING_FOR_TOKEN --| End If --| ElsIF character is white-space --| Set STOP to the previous character's index --| Add slice from START to STOP to list --| Set CURRENT_STATE to LOOKING_FOR_TOKEN --| End If --| End Case --| End Loop --| If CURRENT_STATE is IN_TOKEN --| Set STOP to the previous character's index --| Add slice from START to STOP to list --| End if --| Set LOCAL_ARGC to NUMBER_OF_STRINGS --========================================================= START : NATURAL; STOP : NATURAL; QUOTED : BOOLEAN; type STATE is (LOOKING_FOR_TOKEN, IN_TOKEN); CURRENT_STATE : STATE := LOOKING_FOR_TOKEN; begin STRING_LIST.RESET; if ITEM'LENGTH > 0 then for I in ITEM'RANGE loop case CURRENT_STATE is when LOOKING_FOR_TOKEN => if ITEM (I) > ' ' then CURRENT_STATE := IN_TOKEN; if ITEM (I) = '"' then QUOTED := TRUE; START := I; else QUOTED := FALSE; START := I; end if; end if; when IN_TOKEN => if QUOTED then if ITEM (I) = '"' then STOP := I; STRING_LIST.ADD_TO_LIST (ITEM (START .. STOP)); CURRENT_STATE := LOOKING_FOR_TOKEN; end if; elsif ITEM (I) <= ' ' then STOP := I - 1; STRING_LIST.ADD_TO_LIST (ITEM (START .. STOP)); CURRENT_STATE := LOOKING_FOR_TOKEN; end if; end case; end loop; if CURRENT_STATE = IN_TOKEN then STOP := ITEM'LAST; STRING_LIST.ADD_TO_LIST (ITEM (START .. STOP)); end if; LOCAL_ARGC := STRING_LIST.NUMBER_OF_STRINGS; else LOCAL_ARGC := 0; end if; end INITIALIZE; function ARGC return NATURAL is --========================= PDL =========================== --|ABSTRACT: --| ARGC returns the count of the number of tokens. --|DESIGN DESCRIPTION: --| Return LOCAL_ARGC (set by INITIALIZE) --========================================================= begin return LOCAL_ARGC; end ARGC; function ARGV (INDEX : in NATURAL) return STRING is --========================= PDL =========================== --|ABSTRACT: --| ARGV returns the indicated argument string. --|DESIGN DESCRIPTION: --| If INDEX is out of range, raise INVALID_INDEX --| Return GET_FROM_LIST(INDEX) --========================================================= begin if INDEX < 0 or INDEX >= LOCAL_ARGC then raise INVALID_INDEX; end if; return STRING_LIST.GET_FROM_LIST (INDEX); exception when INVALID_INDEX => raise ; when others => raise UNEXPECTED_ERROR; end ARGV; end LINE_PARSER; --:::::::::: --matrix.bdy --:::::::::: -- **************************************************************** -- * * -- * Matrix_Package * BODY -- * * -- **************************************************************** with text_io; use text_io; package body MATRIX_PACKAGE is --| Notes --| Modifications by Art Adamson -- -- Mod by A. P. Adamson..July 1990..Added cross product of vectors. -- The added function Vector1 ** Vector2 return Vector3 is limited to -- 3-D vectors. Vector3 = Vector1 cross Vector2. -- Mod by A. P. Adamson..Oct. 6, 1990..Added VEC2T, a 2D VECTOR subtype. -- Mod by A. P. Adamson..Oct. 6, 1990..Added VEC3T, a 3D VECTOR subtype. -- Mod by A. P. Adamson..Oct. 6, 1990..Added MATR2T, a VECTOR but with -- elements of VEC2T rather than float. -- Mod by A. P. Adamson..Oct. 6, 1990..Added +, an operation to add a float -- to each term of a VECTOR. -- Mod by A. P. Adamson..Oct. 6, 1990..Added *, an operation to multiply -- each VEC2T of a MATR2T by a single float. -- Mod by A. P. Adamson..Oct. 6, 1990..Added *, an operation to dot product -- each VEC2T of a MATR2T by a single VEC2T. -- Mod by A. P. Adamson..Oct. 15, 1990..Added JCROSS, an operation to cross -- product a fictitious unit vector j in y direction with a VEC2T having -- components only in the x and z directions. Result is a VEC2T. Used to -- allow direct translation of certain 3d vector formulas into 2d space. -- Net effect is to rotate the vec2t 90 degrees CW. -- Mod by A. P. Adamson..Oct. 15, 1990..Added + , an operation to add a -- VEC2T to each term of a MATR2T. -- Mod by A. P. Adamson..Oct. 15, 1990..Added * , an operation to multiply -- each term of a MATR2T by a correspunding float term from a vector. -- Mod by A. P. Adamson..Oct. 15, 1990..Added + , an operation to add -- corresponding VEC2T's of two MATR2T and return MATR2T. -- Mod by A. P. Adamson..Nov. 3, 1990..Added ROTX and ROTY operations to -- rotate a VEC2T 180 degrees about the X axis or the Y axis. -- Mod by A. P. Adamson..Nov. 11, 1990..Added MAT4MULT operation to -- column multiply 4 square input matricees (the 4 corner quarters of a larger -- matrix) by a column vector and return a column vector. Useful when a matrix -- is too large for the memory capacity. -- Mod by A. P. Adamson..Jan. 1, 1991..Added aXbDOTj operation to -- give scalar = mag of A cross B for 2 VEC2T vectors. -- VEC2T has no third dimensoin so the cross product is not possible. -- Mod by A. P. Adamson..Jan. 1, 1991..Added GETTAN operation to get the TAN -- of angle theta between 2 VEC2T vectors. -- Mod by A. P. Adamson..Feb. 15, 1992..Added GETTAN operation protection --for divide by 0 when angle = PI/2. --- function TRANSPOSE(A : MATRIX) return MATRIX is B : MATRIX(A'first(2)..A'last(2),A'first(1)..A'last(1)) ; -- ****************************************************************** -- This function performs the tranpose of input matrix A -- ****************************************************************** begin for I in A'range(2) loop for J in A'range(1) loop B(I,J) := A(J,I) ; end loop ; end loop ; return B ; end TRANSPOSE; --- function TRANSPOSE(A : VECTOR) return VECTOR is -- ***************************************************************** -- This function returns the transpose of a vector. In programming -- a vector is always stored as one-dimensional array. Therefore, -- there is no difference between row vector and column vector. -- Thus, this function just returns the input vector (do nothing). -- ***************************************************************** begin return A; end TRANSPOSE; --- function "+" (A : VECTOR; B : VECTOR) return VECTOR is C : VECTOR(A'first..A'last) ; -- ************************************************************** -- This function performs the addition of vector A and vector B -- resulting in a vector. Comparability of dimensions is checked. -- ************************************************************** begin if A'first /= B'first or A'last /= B'last then raise INCOMPARABLE_DIMENSION; end if ; for I in A'range loop C(I) := A(I)+B(I) ; end loop ; return C ; end "+"; --- function "+" (A : float; B : VECTOR) return VECTOR is C : VECTOR(B'first..B'last) ; -- ************************************************************** -- This function performs the addition of a FLOAT A to each term -- of vector B resulting in a vector. -- ************************************************************** begin for I in B'range loop C(I) := A + B(I) ; end loop ; return C ; end "+"; --- function "+" (A : MATRIX; B : MATRIX) return MATRIX is C : MATRIX(A'first(1)..A'last(1),A'first(2)..A'last(2)) ; -- ******************************************************************* -- This function performs the addition of matrix A and matrix B -- resulting in a matrix. Comparability of dimensions is checked. -- ******************************************************************* begin if (A'first(1) /= B'first(1) or A'last(1) /= B'last(1)) or (A'first(2) /= B'first(2) or A'last(2) /= B'last(2)) then raise INCOMPARABLE_DIMENSION; end if ; for I in A'range(1) loop for J in A'range(2) loop C(I,J) := A(I,J)+B(I,J) ; end loop ; end loop ; return C ; end "+"; -- function "+" (A : VEC2T; B : MATR2T) return MATR2T is TEMP : MATR2T(B'range); -- ********************************************************************** -- Vec2T added to, each term of MATR2T -- ********************************************************************** begin for I in B'range loop TEMP(I) := A + B(I); end loop; return TEMP; end "+"; -- function "+" (A : MATR2T; B : MATR2T) return MATR2T is TEMP : MATR2T(B'range); -- ********************************************************************** -- Vec2T added to, each term of MATR2T -- ********************************************************************** begin for I in B'range loop TEMP(I) := A(I) + B(I); end loop; return TEMP; end "+"; -- function "-" (A : VECTOR; B : VECTOR) return VECTOR is C : VECTOR(A'first..A'last) ; -- ****************************************************************** -- This function performs the subtraction of vector B from vector A -- resulting in a vector. Comparability of dimensions is checked. -- ****************************************************************** begin if A'first /= B'first or A'last /= B'last then raise INCOMPARABLE_DIMENSION; end if ; for I in A'range loop C(I) := A(I)-B(I) ; end loop ; return C ; end "-"; --- function "-" (A : MATRIX; B : MATRIX) return MATRIX is C : MATRIX(A'first(1)..A'last(1),A'first(2)..A'last(2)) ; -- ****************************************************************** -- This function performs the subtraction of matrix B from matrix A -- resulting in a matrix. Comparability of dimensions is checked. -- ****************************************************************** begin if (A'first(1) /= B'first(1) or A'last(1) /= B'last(1)) or (A'first(2) /= B'first(2) or A'last(2) /= B'last(2)) then raise INCOMPARABLE_DIMENSION; end if ; for I in A'range(1) loop for J in A'range(2) loop C(I,J) := A(I,J)-B(I,J) ; end loop ; end loop ; return C ; end "-"; --- function "*" (A:float; B:VECTOR) return VECTOR is C: VECTOR(B'first..B'last); -- ****************************************************************** -- This function performs the scalar multiplication of a floating -- number A and a vector B resulting in a vector. -- ****************************************************************** begin for I in B'range loop C(I):=A*B(I); end loop; return C ; end "*"; --- function "*" (A:VECTOR; B:float) return VECTOR is begin -- ******************************************************************** -- This function performs the scalar multiplication of a vector A and -- a floating number B resulting in a vector. -- ******************************************************************** return B*A; end "*"; --- function "*" (A : VECTOR; B : VECTOR) return float is S :float:=0.0; -- ******************************************************************* -- This function performs the inner (dot) product of two vectors A -- and B resulting in a floating number. -- Comparability of dimensions is checked. -- ******************************************************************* begin if A'first /= B'first or A'last /= B'last then raise INCOMPARABLE_DIMENSION; end if ; for I in A'range loop S := S+A(I)*B(I) ; end loop ; return S ; end "*"; --- function "*" (A:MATRIX; B:VECTOR) return VECTOR is C:VECTOR(A'first(1)..A'last(1)); SUM:float; -- ********************************************************************** -- This function performs the multiplication of a matrix A and a column -- vector B resulting in a column vector. -- Comparability of dimensions is checked. -- ********************************************************************** begin if A'first(2)/=B'first or A'last(2) /= B'last then raise INCOMPARABLE_DIMENSION; end if ; for I in A'range(1) loop SUM := 0.0 ; for K in A'range(2) loop SUM := SUM+A(I,K)*B(K); end loop; C(I):=SUM; end loop ; return C ; end "*"; --- function mat4mult (UL : MATRIX; UR : MATRIX; BL : MATRIX; BR : MATRIX; B : VECTOR) return VECTOR is C:VECTOR(B'first..B'last); SUMT, SUMB : float; -- ********************************************************************** -- This function performs the multiplication of a matrix A, broken into -- 4 smaller ones due to memory limitations, and a column vector B -- resulting in a column vector. Comparability of dimensions is -- partially checked. -- ********************************************************************** begin if UL'length (1) /= UR'length (1) or UL'length (1) /= BL'length (1) or UL'length (1) /= BR'length (1) or UL'length (2) /= UR'length (2) or UL'length (2) /= BL'length (2) or UL'length (2) /= BR'length (2) or UL'length (2) /= UL'length (1) then raise INCOMPARABLE_DIMENSION; end if; if UL'first(1) /= B'first or UL'last(1) /= B'last/2 then raise INCOMPARABLE_DIMENSION; end if; if UL'first(2) /= B'first or UL'last(2) /= B'last/2 or UL'first(1) /= B'first or UL'last(1) /= B'last/2 or UL'last(1) /= UL'last(2) then raise INCOMPARABLE_DIMENSION; end if ; for I in UL'range(1) loop SUMT := 0.0 ; SUMB := 0.0 ; for K in UL'range(2) loop SUMT := SUMT+UL(I,K)*B(K) + UR(I,K) * B(k + UL'last(2)); SUMB := SUMB+BL(I,K)*B(K) + BR(I,K) * B(k + UL'last(2)); end loop; C(I):=SUMT; C(I + UL'last(2)):=SUMB; end loop ; return C ; end mat4mult; --- function "*" (A:VECTOR; B:MATRIX) return VECTOR is C:VECTOR(B'first(2)..B'last(2)); SUM:float; -- ******************************************************************** -- This function performs the multiplication of a row vector A and a -- matrix B resulting in a row vector. -- Comparability of dimensions is checked. -- ******************************************************************** begin if A'first/=B'first(1) or A'last/=B'last(1) then raise INCOMPARABLE_DIMENSION; end if ; for J in B'range(2) loop SUM := 0.0 ; for K in A'range loop SUM := SUM+A(K)*B(K,J); end loop; C(J):=SUM; end loop ; return C ; end "*"; --- function "*" (A:float; B:MATRIX) return MATRIX is C:MATRIX(B'first(1)..B'last(1),B'first(2)..B'last(2)); -- ******************************************************************** -- This function performs the scalar multipliction of a matrix B by -- a floating number A resulting in a matrix. -- ******************************************************************** begin for I in B'range(1) loop for J in B'range(2) loop C(I,J) := A*B(I,J); end loop ; end loop ; return C ; end "*"; --- function "*" (A:MATRIX; B:float) return MATRIX is C:MATRIX(A'first(1)..A'last(1),A'first(2)..A'last(2)); -- ***************************************************************** -- This function performs the scalar multipliction of a matrix A -- by a floating number B resulting in a matrix. -- ***************************************************************** begin return B*A ; end "*"; --- function "*" (A:MATRIX; B:MATRIX) return MATRIX is C:MATRIX(A'first(1)..A'last(1),B'first(2)..B'last(2)); SUM: float; -- ******************************************************************** -- This function performs the multiplication of matrix A and matrix B -- resulting in a matrix. Comparability of dimensions is checked. -- ******************************************************************** begin if A'first(2)/=B'first(1) or A'last(2)/=B'last(1) then raise INCOMPARABLE_DIMENSION; end if ; for I in A'range(1) loop for J in B'range(2) loop SUM := 0.0 ; for K in A'range(2) loop SUM := SUM+A(I,K)*B(K,J); end loop; C(I,J) := SUM; end loop ; end loop ; return C ; end "*"; --- function "*" (A : float; B : MATR2T) return MATR2T is C : MATR2T(B'first(1)..B'last(1)); -- ********************************************************************** -- This function performs the multiplication of each element of a -- MATR2T by a FLOAT resulting in a MATR2T. -- ********************************************************************** begin for I in B'range(1) loop C(I) := A * B(I); end loop ; return C ; end "*"; --- function "*" (A : VEC2T; B : MATR2T) return VECTOR is C : VECTOR(B'first(1)..B'last(1)); -- ********************************************************************** -- This function performs the DOT PRODUCT of each element of a -- MATR2T by a VEC2T resulting in a VECTOR. -- ********************************************************************** begin for I in B'range(1) loop C(I) := A * B(I); end loop ; return C ; end "*"; --- function "*" (A : VECTOR; B : MATR2T) return MATR2T is TEMP : MATR2T(B'range); -- ********************************************************************** -- This function multiplies each VEC2T of a MATR2T by a float from a -- the corresponding term of a VECTOR resulting in a MATR2T. -- ********************************************************************** begin if A'first /= B'first or A'last /= B'last then raise INCOMPARABLE_DIMENSION; end if; for I in B'range loop TEMP(I) := A(I) * B(I); end loop; return TEMP; end "*"; function "**" (A : MATRIX; P : integer) return MATRIX is B,C : MATRIX(A'first(1)..A'last(1), A'first(1)..A'last(1)); I_PIVOT,J_PIVOT : integer range A'first(1)..A'last(1); BIG_ENTRY, TEMP, EPSILON : float ; L, M : array(A'range(1)) of integer ; -- ******************************************************************* -- This function performs the square matrix operation of " matrix A -- raise to integer power P ". When P is negative , say P = -N , -- A**(-N) = (inverse(A))**N , that is, the inverse of A raise to -- power N . In this case, matrix A must be non-singular. -- Exceptions will be raised if the matrix A is not a square matrix, -- or if matrix A is singular. -- ******************************************************************* begin if A'first(1)/=A'first(2) or A'last(1)/=A'last(2) then -- if not a square matrix raise INCOMPARABLE_DIMENSION ; end if; if P=0 then --& B = identity matrix for I in A'range(1) loop for J in A'range(1) loop if I /= J then B(I,J) := 0.0; else B(I,J) := 1.0; end if; end loop; end loop; return B; end if ; B := A ; if P>0 then --& B = A multiplied itself for P times for I in 1..P-1 loop B := B*A ; end loop ; return B ; end if; -- P is negative, find inverse first -- initiate the row and column interchange information for K in B'range(1) loop L(K) := K ; -- row interchage information M(K) := K ; -- column interchange information end loop; -- major loop for inverse for K in B'range(1) loop -- & search for row and column index I_PIVOT, J_PIVOT -- & both in (K .. B'LAST(1) ) for maximum B(I,J) -- & in absolute value :BIG_ENTRY BIG_ENTRY := 0.0 ; -- -- check matrix singularity -- for I in K..B'last(1) loop for J in K..B'last(1) loop if abs(B(I,J)) > abs(BIG_ENTRY) then BIG_ENTRY := B(I,J) ; I_PIVOT := I ; J_PIVOT := J ; end if; end loop; end loop; if K = B'first(1) then if BIG_ENTRY = 0.0 then raise SINGULAR; else EPSILON := float(A'length(1))*abs(BIG_ENTRY) *0.000001; end if; else if abs(BIG_ENTRY) < EPSILON then raise SINGULAR ; end if; end if; -- interchange row and column --& interchange K-th and I_PIVOT-th rows if I_PIVOT/=K then for J in B'range(1) loop TEMP := B(I_PIVOT,J); B(I_PIVOT,J) := B(K,J) ; B(K,J) := TEMP ; end loop; L(K) := I_PIVOT ; end if; --& interchange K-th and J_PIVOT-th columns if J_PIVOT/=K then for I in B'range(1) loop TEMP := B(I,J_PIVOT) ; B(I,J_PIVOT) := B(I,K) ; B(I,K) := TEMP ; end loop ; M(K) := J_PIVOT ; end if ; --& divide K-th column by minus pivot (-BIG_ENTRY) for I in B'range(1) loop if I/=K then B(I,K) := B(I,K)/(-BIG_ENTRY) ; end if; end loop ; -- reduce matrix row by row for I in B'range(1) loop if I/=K then for J in B'range(1) loop if J/=K then B(I,J):=B(I,J)+B(I,K)*B(K,J); end if ; end loop ; end if ; end loop ; --& divide K-th row by pivot for J in B'range(1) loop if J/=K then B(K,J) := B(K,J)/BIG_ENTRY ; end if ; end loop ; B(K,K) := 1.0/BIG_ENTRY ; end loop ; -- end of major inverse loop -- final column and row interchange to obtain -- inverse of A, i.e. A**(-1) for K in reverse B'range(1) loop -- column interchage J_PIVOT := L(K) ; if J_PIVOT/=K then --& intechange B(I,J_PIVOT) and B(I,K) for each row I for I in B'range(1) loop TEMP := B(I,J_PIVOT) ; B(I,J_PIVOT) := B(I,K) ; B(I,K) := TEMP ; end loop ; end if ; -- row interchage I_PIVOT := M(K) ; if I_PIVOT/=K then --& INTECHANGE B(I_PIVOT,J) and B(K,J) for each column J for J in B'range(1) loop TEMP := B(I_PIVOT,J) ; B(I_PIVOT,J) := B(K,J) ; B(K,J) := TEMP ; end loop ; end if ; end loop ; -- inverse of A is obtained and stored in B -- now ready to handle the negative power -- & C = B**(-P) if P=-1 then return B ; end if ; C := B ; for I in P+1..-1 loop C:= C*B ; end loop ; return C; end "**" ; --- function "**" (A : VECTOR; B : VECTOR) return VECTOR is VTEMP : VECTOR (1..3); -- ******************************************************************* -- This function performs the cross product of two vectors A -- and B resulting in a VECTOR. Usage, C := A ** B; -- Comparability of dimensions is checked. LIMITED TO 3D. -- ******************************************************************* begin if A'first /= B'first or A'last /= B'last then raise INCOMPARABLE_DIMENSION; end if ; VTEMP(1) := A(2) * B(3) - A(3) * B(2); VTEMP(2) := A(3) * B(1) - A(1) * B(3); VTEMP(3) := A(1) * B(2) - A(2) * B(1); return VTEMP ; end "**"; --- function JCROSS (A : VEC2T) return VEC2T is --**************************************************************************** -- This function rotates a Vec2T 90 degrees cw. --**************************************************************************** VTEMP : VEC2T; begin VTEMP := (A(2), ((-1.0) * A(1))); return VTEMP; end JCROSS; --- function JCROSS (A : MATR2T) return MATR2T is --**************************************************************************** -- This function rotates each component Vec2T of MATR2T 90 degrees cw. --**************************************************************************** B : MATR2T(A'first(1)..A'last(1)); begin for I in A'range loop B(I) := JCROSS(A(I)); end loop; return B; end JCROSS; --- function ROTX (A : VEC2T) return VEC2T is --**************************************************************************** -- This function rotates a Vec2T 180 degrees about the X axis. --**************************************************************************** begin return (A(1), -A(2)); end ROTX; --- function ROTY (A : VEC2T) return VEC2T is --************************************************************************ -- This function rotates a Vec2T 180 degrees about the Y axis. --************************************************************************ begin return (-A(1), A(2)); end ROTY; --- function aXbDOTj(A : VEC2T; B : VEC2T) return FLOAT is --************************************************************************ --Gets magnitude of A cross B for 2 2D vectors. --************************************************************************ temp : float; begin temp := A(2) * B(1) - A(1) * B(2); return temp; end aXbDOTj; --- function GETTAN (A : VEC2T; B : VEC2T) return FLOAT is --************************************************************************ --Gets TAN(THETA) where THETA is CW angle between 2 2D vectors. --************************************************************************ epsilon, num, denom : float := 0.00000001; begin denom := A * B; num := aXbDOTj(A,B); if denom < epsilon and denom >= 0.0 then put_line("Tangent is beyond the limit val of"); return (num / epsilon); elsif denom > -epsilon and denom < 0.0 then put_line("Tangent is beyond the limit val of"); return ((-num) / epsilon); else return aXbDOTj(A,B)/(A * B); end if; end gettan; end MATRIX_PACKAGE; --:::::::::: --mlib.bdy --:::::::::: package body FLOATING_CHARACTERISTICS is -- This package is a floating mantissa definition of a binary FLOAT A, B, Y, Z : FLOAT; I, K, MX, IZ : INTEGER; BETA, BETAM1, BETAIN : FLOAT; ONE : FLOAT := 1.0; ZERO : FLOAT := 0.0; procedure DEFLOAT(X : in FLOAT; L : out EXPONENT_TYPE; E : out MANTISSA_TYPE) is -- This is admittedly a slow method - but portable - for breaking down -- a floating point number into its exponent and mantissa -- Obviously with knowledge of the machine representation -- it could be replaced with a couple of simple extractions EXPONENT_LENGTH : INTEGER := IEXP; M, N : EXPONENT_TYPE; W, Y, Z : FLOAT; F : MANTISSA_TYPE; begin N := 0; F := 0.0; Y := ABS(X); if Y = 0.0 then return; elsif Y < 0.5 then for J in reverse 0..(EXPONENT_LENGTH - 2) loop -- Dont want to go all the way to 2.0**(EXPONENT_LENGTH - 1) -- Since that (or its reciprocal) will overflow if exponent biased -- Ought to use talbular values rather than compute each time M := EXPONENT_TYPE(2 ** J); Z := 1.0 / (2.0**M); W := Y / Z; if W < 1.0 then Y := W; N := N - M; end if; end loop; else for J in reverse 0..(EXPONENT_LENGTH - 2) loop M := EXPONENT_TYPE(2 ** J); Z := 2.0**M; W := Y / Z; if W >= 0.5 then Y := W; N := N + M; end if; end loop; -- And just to clear up any loose ends from biased exponents end if; while Y < 0.5 loop Y := Y * 2.0; N := N - 1; end loop; while Y >= 1.0 loop Y := Y / 2.0; N := N + 1; end loop; F := MANTISSA_TYPE(Y); if X < 0.0 then F := -F; end if; L := N; E := F; return; exception when others => L := 0; E := 0.0; return; end DEFLOAT; procedure REFLOAT(N : in EXPONENT_TYPE; F : in MANTISSA_TYPE; Z : out FLOAT) is -- Again a brute force method - but portable -- Watch out near MAXEXP M : INTEGER; X, Y : FLOAT; begin if F = 0.0 then X := ZERO; return; end if; M := INTEGER(N); Y := ABS(FLOAT(F)); while Y < 0.5 loop M := M - 1; if M < MINEXP then X := ZERO; end if; Y := Y + Y; exit when M <= MINEXP; end loop; if M = MAXEXP then M := M - 1; X := Y * 2.0**M; X := X * 2.0; elsif M <= MINEXP + 2 then M := M + 3; X := Y * 2.0**M; X := ((X / 2.0) / 2.0) / 2.0; else X := Y * 2.0**M; end if; if F < 0.0 then X := -X; end if; Z := X; return; end REFLOAT; function CONVERT_TO_FLOAT(K : INTEGER) return FLOAT is begin return FLOAT(K); end CONVERT_TO_FLOAT; --function CONVERT_TO_FLOAT(N : EXPONENT_TYPE) return FLOAT is --begin --return FLOAT(N); --end CONVERT_TO_FLOAT; function CONVERT_TO_FLOAT(F : MANTISSA_TYPE) return FLOAT is begin return FLOAT(F); end CONVERT_TO_FLOAT; begin -- Initialization for the VAX with values derived by MACHAR -- In place of running MACHAR as the actual initialization IBETA := 2; IT := 24; IRND := 1; NEGEP := -24; EPSNEG := 5.9604644E-008; MACHEP := -24; EPS := 5.9604644E-008; NGRD := 0; XMIN := 5.9E-39; MINEXP := -126; IEXP := 8; MAXEXP := 127; XMAX := 8.5E37 * 2.0; ---- This initialization is the MACHAR routine of Cody and Waite Appendix B. --PUT("INITIALIZATING WITH MACHAR - "); -- A := ONE; -- while (((A + ONE) - A) - ONE) = ZERO loop -- A := A + A; -- end loop; -- B := ONE; -- while ((A + B) - A) = ZERO loop -- B := B + B; -- end loop; -- IBETA := INTEGER((A + B) - A); -- BETA := CONVERT_TO_FLOAT(IBETA); -- -- -- IT := 0; -- B := ONE; -- while (((B + ONE) - B) - ONE) = ZERO loop -- IT := IT + 1; -- B := B * BETA; -- end loop; -- -- -- IRND := 0; -- BETAM1 := BETA - ONE; -- if ((A + BETAM1) - A) /= ZERO then -- IRND := 1; -- end if; -- -- -- NEGEP := IT + 3; -- BETAIN := ONE / BETA; -- A := ONE; -- -- for I in 1..NEGEP loop -- for I in 1..50 loop -- exit when I > NEGEP; -- A := A * BETAIN; -- end loop; -- B := A; -- while ((ONE - A) - ONE) = ZERO loop -- A := A * BETA; -- NEGEP := NEGEP - 1; -- end loop; -- NEGEP := -NEGEP; -- -- -- EPSNEG := A; -- if (IBETA /= 2) and (IRND /= 0) then -- A := (A * (ONE + A)) / (ONE + ONE); -- if ((ONE - A) - ONE) /= ZERO then -- EPSNEG := A; -- end if; -- end if; -- -- -- MACHEP := -IT - 3; -- A := B; -- while ((ONE + A) - ONE) = ZERO loop -- A := A * BETA; -- MACHEP := MACHEP + 1; -- end loop; -- -- -- EPS := A; -- if (IBETA /= 2) and (IRND /= 0) then -- A := (A * (ONE + A)) / (ONE + ONE); -- if ((ONE + A) - ONE) /= ZERO then -- EPS := A; -- end if; -- end if; -- -- -- NGRD := 0; -- if ((IRND = 0) and ((ONE + EPS) * ONE - ONE) /= ZERO) then -- NGRD := 1; -- end if; -- -- -- I := 0; -- K := 1; -- Z := BETAIN; -- loop -- Y := Z; -- Z := Y * Y; -- A := Z * ONE; -- exit when ((A + A) = ZERO) or (ABS(Z) >= Y); -- I := I + 1; -- K := K + K; -- end loop; -- if (IBETA /= 10) then -- IEXP := I + 1; -- MX := K + K; -- else -- IEXP := 2; -- IZ := IBETA; -- while (K >= IZ) loop -- IZ := IZ * IBETA; -- IEXP := IEXP + 1; -- end loop; -- MX := IZ + IZ - 1; -- end if; -- -- loop -- XMIN := Y; -- Y := Y * BETAIN; -- A := Y * ONE; -- exit when ((A + A) = ZERO) or (ABS(Y) >= XMIN); -- K := K + 1; -- end loop; -- -- -- MINEXP := -K; -- -- -- if ((MX <= (K + K - 3)) and (IBETA /= 10)) then -- MX := MX + MX; -- IEXP := IEXP + 1; -- end if; -- -- -- MAXEXP := MX + MINEXP; -- I := MAXEXP + MINEXP; -- if ((IBETA = 2) and (I = 0)) then -- MAXEXP := MAXEXP - 1; -- end if; -- if (I > 20) then -- MAXEXP := MAXEXP - 1; -- end if; -- if (A /= Y) then -- MAXEXP := MAXEXP - 2; -- end if; -- -- -- XMAX := ONE - EPSNEG; -- if ((XMAX * ONE) /= XMAX) then -- XMAX := ONE - BETA * EPSNEG; -- end if; -- XMAX := XMAX / (BETA * BETA * BETA * XMIN); -- I := MAXEXP + MINEXP + 3; -- if I > 0 then -- for J in 1..50 loop -- exit when J > I; -- if IBETA = 2 then -- XMAX := XMAX + XMAX; -- else -- XMAX := XMAX * BETA; -- end if; -- end loop; -- end if; -- --PUT("INITIALIZED"); NEW_LINE; end FLOATING_CHARACTERISTICS; with FLOATING_CHARACTERISTICS; use FLOATING_CHARACTERISTICS; package body NUMERIC_PRIMITIVES is function SIGN(X, Y : FLOAT) return FLOAT is -- Returns the value of X with the sign of Y begin if Y >= 0.0 then return X; else return -X; end if; end SIGN; function MAX(X, Y : FLOAT) return FLOAT is begin if X >= Y then return X; else return Y; end if; end MAX; function TRUNCATE(X : FLOAT) return FLOAT is -- Optimum code depends on how the system rounds at exact halves begin if FLOAT(INTEGER(X)) = X then return X; end if; if X > ZERO then return FLOAT(INTEGER(X - HALF)); elsif X = ZERO then return ZERO; else return FLOAT(INTEGER(X + HALF)); end if; end TRUNCATE; function ROUND(X : FLOAT) return FLOAT is begin return FLOAT(INTEGER(X)); end ROUND; package KEY is X : INTEGER := 10_001; Y : INTEGER := 20_001; Z : INTEGER := 30_001; end KEY; function RAN return FLOAT is -- This rectangular random number routine is adapted from a report -- "A Pseudo-Random Number Generator" by B. A. Wichmann and I. D. Hill -- NPL Report DNACS XX (to be published) -- In this stripped version, it is suitable for machines supporting -- INTEGER at only 16 bits and is portable in Ada W : FLOAT; begin KEY.X := 171 * (KEY.X mod 177 - 177) - 2 * (KEY.X / 177); if KEY.X < 0 then KEY.X := KEY.X + 30269; end if; KEY.Y := 172 * (KEY.Y mod 176 - 176) - 35 * (KEY.Y / 176); if KEY.Y < 0 then KEY.Y := KEY.Y + 30307; end if; KEY.Z := 170 * (KEY.Z mod 178 - 178) - 63 * (KEY.Z / 178); if KEY.Z < 0 then KEY.Z := KEY.Z + 30323; end if; -- CONVERT_TO_FLOAT is used instead of FLOAT since the floating -- type may be software defined W := CONVERT_TO_FLOAT(KEY.X)/30269.0 + CONVERT_TO_FLOAT(KEY.Y)/30307.0 + CONVERT_TO_FLOAT(KEY.Z)/30323.0; return W - CONVERT_TO_FLOAT(INTEGER(W - 0.5)); end RAN; begin ZERO := CONVERT_TO_FLOAT(INTEGER(0)); ONE := CONVERT_TO_FLOAT(INTEGER(1)); TWO := ONE + ONE; THREE := ONE + ONE + ONE; HALF := ONE / TWO; PI := CONVERT_TO_FLOAT(INTEGER(3)) + CONVERT_TO_FLOAT(MANTISSA_TYPE(0.14159_26535_89793_23846)); ONE_OVER_PI := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.31830_98861_83790_67154)); TWO_OVER_PI := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.63661_97723_67581_34308)); PI_OVER_TWO := CONVERT_TO_FLOAT(INTEGER(1)) + CONVERT_TO_FLOAT(MANTISSA_TYPE(0.57079_63267_94896_61923)); PI_OVER_THREE := CONVERT_TO_FLOAT(INTEGER(1)) + CONVERT_TO_FLOAT(MANTISSA_TYPE(0.04719_75511_96597_74615)); PI_OVER_FOUR := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.78539_81633_97448_30962)); PI_OVER_SIX := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.52359_87755_98298_87308)); end NUMERIC_PRIMITIVES; with TEXT_IO; with FLOATING_CHARACTERISTICS; with NUMERIC_PRIMITIVES; package body CORE_FUNCTIONS is use TEXT_IO; use FLOATING_CHARACTERISTICS; use NUMERIC_PRIMITIVES; package FLT_IO is new FLOAT_IO(FLOAT); use FLT_IO; -- The following routines are coded directly from the algorithms and -- coeficients given in "Software Manual for the Elementry Functions" -- by William J. Cody, Jr. and William Waite, Prentice_Hall, 1980 -- CBRT by analogy -- A more general formulation uses MANTISSA_TYPE, etc. -- The coeficients are appropriate for 25 to 32 bits floating significance -- They will work for less but slightly shorter versions are possible -- The routines are coded to stand alone so they need not be compiled together -- These routines have been coded to accept a general MANTISSA_TYPE -- That is, they are designed to work with a manitssa either fixed of float -- There are some explicit conversions which are required but these will -- not cause any extra code to be generated -- 16 JULY 1982 W A WHITAKER AFATL EGLIN AFB FL 32542 -- T C EICHOLTZ USAFA function SQRT(X : FLOAT) return FLOAT is M, N : EXPONENT_TYPE; F, Y : MANTISSA_TYPE; RESULT : FLOAT; subtype INDEX is INTEGER range 0..100; -- ######################### SQRT_L1 : INDEX := 3; -- Could get away with SQRT_L1 := 2 for 28 bits -- Using the better Cody-Waite coeficients overflows MANTISSA_TYPE SQRT_C1 : MANTISSA_TYPE := 8#0.3317777777#; SQRT_C2 : MANTISSA_TYPE := 8#0.4460000000#; SQRT_C3 : MANTISSA_TYPE := 8#0.55202_36314_77747_36311_0#; begin if X = ZERO then RESULT := ZERO; return RESULT; elsif X = ONE then -- To get exact SQRT(1.0) RESULT := ONE; return RESULT; elsif X < ZERO then NEW_LINE; PUT("CALLED SQRT FOR NEGATIVE ARGUMENT "); PUT(X); PUT(" USED ABSOLUTE VALUE"); NEW_LINE; RESULT := SQRT(ABS(X)); return RESULT; else DEFLOAT(X, N, F); Y := SQRT_C1 + MANTISSA_TYPE(SQRT_C2 * F); for J in 1..SQRT_L1 loop Y := Y/MANTISSA_DIVISOR_2 + MANTISSA_TYPE((F/MANTISSA_DIVISOR_2)/Y); end loop; if (N mod 2) /= 0 then Y := MANTISSA_TYPE(SQRT_C3 * Y); N := N + 1; end if; M := N/2; REFLOAT(M,Y,RESULT); return RESULT; end if; exception when others => NEW_LINE; PUT(" EXCEPTION IN SQRT, X = "); PUT(X); PUT(" RETURNED 1.0"); NEW_LINE; return ONE; end SQRT; function CBRT(X : FLOAT) return FLOAT is M, N : EXPONENT_TYPE; F, Y : MANTISSA_TYPE; RESULT : FLOAT; subtype INDEX is INTEGER range 0..100; -- ######################### CBRT_L1 : INDEX := 3; CBRT_C1 : MANTISSA_TYPE := 0.5874009; CBRT_C2 : MANTISSA_TYPE := 0.4125990; CBRT_C3 : MANTISSA_TYPE := 0.62996_05249; CBRT_C4 : MANTISSA_TYPE := 0.79370_05260; begin if X = ZERO then RESULT := ZERO; return RESULT; else DEFLOAT(X, N, F); F := ABS(F); Y := CBRT_C1 + MANTISSA_TYPE(CBRT_C2 * F); for J in 1 .. CBRT_L1 loop Y := Y - ( Y/MANTISSA_DIVISOR_3 - MANTISSA_TYPE((F/MANTISSA_DIVISOR_3) / MANTISSA_TYPE(Y*Y)) ); end loop; case (N mod 3) is when 0 => null; when 1 => Y := MANTISSA_TYPE(CBRT_C3 * Y); N := N + 2; when 2 => Y := MANTISSA_TYPE(CBRT_C4 * Y); N := N + 1; when others => null; end case; M := N/3; if X < ZERO then Y := -Y; end if; REFLOAT(M, Y, RESULT); return RESULT; end if; exception when others => RESULT := ONE; if X < ZERO then RESULT := - ONE; end if; NEW_LINE; PUT("EXCEPTION IN CBRT, X = "); PUT(X); PUT(" RETURNED "); PUT(RESULT); NEW_LINE; return RESULT; end CBRT; function LOG(X : FLOAT) return FLOAT is -- Uses fixed formulation for generality RESULT : FLOAT; N : EXPONENT_TYPE; XN : FLOAT; Y : FLOAT; F : MANTISSA_TYPE; Z, ZDEN, ZNUM : MANTISSA_TYPE; C0 : constant MANTISSA_TYPE := 0.20710_67811_86547_52440; -- SQRT(0.5) - 0.5 C1 : constant FLOAT := 8#0.543#; C2 : constant FLOAT :=-2.12194_44005_46905_82767_9E-4; function R(Z : MANTISSA_TYPE) return MANTISSA_TYPE is -- Use fixed formulation here because the float coeficents are > 1.0 -- and would exceed the limits on a MANTISSA_TYPE A0 : constant MANTISSA_TYPE := 0.04862_85276_587; B0 : constant MANTISSA_TYPE := 0.69735_92187_803; B1 : constant MANTISSA_TYPE :=-0.125; C : constant MANTISSA_TYPE := 0.01360_09546_862; begin return Z + MANTISSA_TYPE(Z * MANTISSA_TYPE(MANTISSA_TYPE(Z * Z) * (C + MANTISSA_TYPE(A0/(B0 + MANTISSA_TYPE(B1 * MANTISSA_TYPE(Z * Z))))))); end R; begin if X < ZERO then NEW_LINE; PUT("CALLED LOG FOR NEGATIVE "); PUT(X); PUT(" USE ABS => "); RESULT := LOG(ABS(X)); PUT(RESULT); NEW_LINE; elsif X = ZERO then NEW_LINE; PUT("CALLED LOG FOR ZERO ARGUMENT, RETURNED "); RESULT := -XMAX; -- SUPPOSED TO BE -LARGE PUT(RESULT); NEW_LINE; else DEFLOAT(X,N,F); ZNUM := F - MANTISSA_HALF; Y := CONVERT_TO_FLOAT(ZNUM); ZDEN := ZNUM / MANTISSA_DIVISOR_2 + MANTISSA_HALF; if ZNUM > C0 then Y := Y - MANTISSA_HALF; ZNUM := ZNUM - MANTISSA_HALF; ZDEN := ZDEN + MANTISSA_HALF/MANTISSA_DIVISOR_2; else N := N -1; end if; Z := MANTISSA_TYPE(ZNUM / ZDEN); RESULT := CONVERT_TO_FLOAT(R(Z)); if N /= 0 then XN := CONVERT_TO_FLOAT(N); RESULT := (XN * C2 + RESULT) + XN * C1; end if; end if; return RESULT; exception when others => NEW_LINE; PUT(" EXCEPTION IN LOG, X = "); PUT(X); PUT(" RETURNED 0.0"); NEW_LINE; return ZERO; end LOG; function LOG10(X : FLOAT) return FLOAT is LOG_10_OF_2 : constant FLOAT := CONVERT_TO_FLOAT(MANTISSA_TYPE(8#0.33626_75425_11562_41615#)); begin return LOG(X) * LOG_10_OF_2; end LOG10; function EXP(X : FLOAT) return FLOAT is RESULT : FLOAT; N : EXPONENT_TYPE; XG, XN, X1, X2 : FLOAT; F, G : MANTISSA_TYPE; BIGX : FLOAT := EXP_LARGE; SMALLX : FLOAT := EXP_SMALL; ONE_OVER_LOG_2 : constant FLOAT := 1.4426_95040_88896_34074; C1 : constant FLOAT := 0.69335_9375; C2 : constant FLOAT := -2.1219_44400_54690_58277E-4; function R(G : MANTISSA_TYPE) return MANTISSA_TYPE is Z , GP, Q : MANTISSA_TYPE; P0 : constant MANTISSA_TYPE := 0.24999_99999_9992; P1 : constant MANTISSA_TYPE := 0.00595_04254_9776; Q0 : constant MANTISSA_TYPE := 0.5; Q1 : constant MANTISSA_TYPE := 0.05356_75176_4522; Q2 : constant MANTISSA_TYPE := 0.00029_72936_3682; begin Z := MANTISSA_TYPE(G * G); GP := MANTISSA_TYPE( (MANTISSA_TYPE(P1 * Z) + P0) * G ); Q := MANTISSA_TYPE( (MANTISSA_TYPE(Q2 * Z) + Q1) * Z ) + Q0; return MANTISSA_HALF + MANTISSA_TYPE( GP /(Q - GP) ); end R; begin if X > BIGX then NEW_LINE; PUT(" EXP CALLED WITH TOO BIG A POSITIVE ARGUMENT, "); PUT(X); PUT(" RETURNED XMAX"); NEW_LINE; RESULT := XMAX; elsif X < SMALLX then NEW_LINE; PUT(" EXP CALLED WITH TOO BIG A NEGATIVE ARGUMENT, "); PUT(X); PUT(" RETURNED ZERO"); NEW_LINE; RESULT := ZERO; elsif ABS(X) < EPS then RESULT := ONE; else N := EXPONENT_TYPE(X * ONE_OVER_LOG_2); XN := CONVERT_TO_FLOAT(N); X1 := ROUND(X); X2 := X - X1; XG := ( (X1 - XN * C1) + X2 ) - XN * C2; G := MANTISSA_TYPE(XG); N := N + 1; F := R(G); REFLOAT(N, F, RESULT); end if; return RESULT; exception when others => NEW_LINE; PUT(" EXCEPTION IN EXP, X = "); PUT(X); PUT(" RETURNED 1.0"); NEW_LINE; return ONE; end EXP; function "**" (X, Y : FLOAT) return FLOAT is -- This is the last function to be coded since it appeared that it really -- was un-Ada-like and ought not be in the regular package -- Nevertheless it was included in this version -- It is specific for FLOAT and does not have the MANTISSA_TYPE generality M, N : EXPONENT_TYPE; G : MANTISSA_TYPE; P, TEMP, IW1, I : INTEGER; RESULT, Z, V, R, U1, U2, W, W1, W2, W3, Y1, Y2 : FLOAT; K : constant FLOAT := 0.44269_50408_88963_40736; IBIGX : constant INTEGER := INTEGER(TRUNCATE(16.0 * LOG(XMAX) - 1.0)); ISMALLX : constant INTEGER := INTEGER(TRUNCATE(16.0 * LOG(XMIN) + 1.0)); P1 : constant FLOAT := 0.83333_32862_45E-1; P2 : constant FLOAT := 0.12506_48500_52E-1; Q1 : constant FLOAT := 0.69314_71805_56341; Q2 : constant FLOAT := 0.24022_65061_44710; Q3 : constant FLOAT := 0.55504_04881_30765E-1; Q4 : constant FLOAT := 0.96162_06595_83789E-2; Q5 : constant FLOAT := 0.13052_55159_42810E-2; A1 : array (1 .. 17) of FLOAT:= ( 8#1.00000_0000#, 8#0.75222_5750#, 8#0.72540_3067#, 8#0.70146_3367#, 8#0.65642_3746#, 8#0.63422_2140#, 8#0.61263_4520#, 8#0.57204_2434#, 8#0.55202_3631#, 8#0.53254_0767#, 8#0.51377_3265#, 8#0.47572_4623#, 8#0.46033_7602#, 8#0.44341_7233#, 8#0.42712_7017#, 8#0.41325_3033#, 8#0.40000_0000# ); A2 : array (1 .. 8) of FLOAT := ( 8#0.00000_00005_22220_66302_61734_72062#, 8#0.00000_00003_02522_47021_04062_61124#, 8#0.00000_00005_21760_44016_17421_53016#, 8#0.00000_00007_65401_41553_72504_02177#, 8#0.00000_00002_44124_12254_31114_01243#, 8#0.00000_00000_11064_10432_66404_42174#, 8#0.00000_00004_72542_16063_30176_55544#, 8#0.00000_00001_74611_03661_23056_22556# ); function REDUCE (V : FLOAT) return FLOAT is begin return FLOAT(INTEGER(16.0 * V)) * 0.0625; end REDUCE; begin if X <= ZERO then if X < ZERO then RESULT := (ABS(X))**Y; NEW_LINE; PUT("X**Y CALLED WITH X = "); PUT(X); NEW_LINE; PUT("USED ABS, RETURNED "); PUT(RESULT); NEW_LINE; else if Y <= ZERO then if Y = ZERO then RESULT := ZERO; else RESULT := XMAX; end if; NEW_LINE; PUT("X**Y CALLED WITH X = 0, Y = "); PUT(Y); NEW_LINE; PUT("RETURNED "); PUT(RESULT); NEW_LINE; else RESULT := ZERO; end if; end if; else DEFLOAT(X, M, G); P := 1; if G <= A1(9) then P := 9; end if; if G <= A1(P+4) then P := P + 4; end if; if G <= A1(P+2) then P := P + 2; end if; Z := ((G - A1(P+1)) - A2((P+1)/2))/(G + A1(P+1)); Z := Z + Z; V := Z * Z; R := (P2 * V + P1) * V * Z; R := R + K * R; U2 := (R + Z * K) + Z; U1 := FLOAT(INTEGER(M) * 16 - P) * 0.0625; Y1 := REDUCE(Y); Y2 := Y - Y1; W := U2 * Y + U1 * Y2; W1 := REDUCE(W); W2 := W - W1; W := W1 + U1 * Y1; W1 := REDUCE(W); W2 := W2 + (W - W1); W3 := REDUCE(W2); IW1 := INTEGER(TRUNCATE(16.0 * (W1 + W3))); W2 := W2 - W3; if W > FLOAT(IBIGX) then RESULT := XMAX; PUT("X**Y CALLED X ="); PUT(X); PUT(" Y ="); PUT(Y); PUT(" TOO LARGE RETURNED "); PUT(RESULT); NEW_LINE; elsif W < FLOAT(ISMALLX) then RESULT := ZERO; PUT("X**Y CALLED X ="); PUT(X); PUT(" Y ="); PUT(Y); PUT(" TOO SMALL RETURNED "); PUT(RESULT); NEW_LINE; else if W2 > ZERO then W2 := W2 - 0.0625; IW1 := IW1 + 1; end if; if IW1 < INTEGER(ZERO) then I := 0; else I := 1; end if; M := EXPONENT_TYPE(I + IW1/16); P := 16 * INTEGER(M) - IW1; Z := ((((Q5 * W2 + Q4) * W2 + Q3) * W2 + Q2) * W2 + Q1) * W2; Z := A1(P+1) + (A1(P+1) * Z); REFLOAT(M, Z, RESULT); end if; end if; return RESULT; end "**"; begin EXP_LARGE := LOG(XMAX) * (ONE - EPS); EXP_SMALL := LOG(XMIN) * (ONE - EPS); end CORE_FUNCTIONS; with TEXT_IO; with FLOATING_CHARACTERISTICS; with NUMERIC_PRIMITIVES; with CORE_FUNCTIONS; package body TRIG_FUNCTIONS is use TEXT_IO; use FLOATING_CHARACTERISTICS; use NUMERIC_PRIMITIVES; use CORE_FUNCTIONS; package FLT_IO is new FLOAT_IO(FLOAT); use FLT_IO; -- PRELIMINARY VERSION ********************************* -- The following routines are coded directly from the algorithms and -- coeficients given in "Software Manual for the Elementry Functions" -- by William J. Cody, Jr. and William Waite, Prentice_Hall, 1980 -- This particular version is stripped to work with FLOAT and INTEGER -- and uses a mantissa represented as a FLOAT -- A more general formulation uses MANTISSA_TYPE, etc. -- The coeficients are appropriate for 25 to 32 bits floating significance -- They will work for less but slightly shorter versions are possible -- The routines are coded to stand alone so they need not be compiled together -- 16 JULY 1982 W A WHITAKER AFATL EGLIN AFB FL 32542 -- T C EICHOLTZ USAFA function SIN(X : FLOAT) return FLOAT is SGN, Y : FLOAT; N : INTEGER; XN : FLOAT; F, G, X1, X2 : FLOAT; RESULT : FLOAT; YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2))); BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); C1 : constant FLOAT := 3.140625; C2 : constant FLOAT := 9.6765_35897_93E-4; function R(G : FLOAT) return FLOAT is R1 : constant FLOAT := -0.16666_66660_883; R2 : constant FLOAT := 0.83333_30720_556E-2; R3 : constant FLOAT := -0.19840_83282_313E-3; R4 : constant FLOAT := 0.27523_97106_775E-5; R5 : constant FLOAT := -0.23868_34640_601E-7; begin return ((((R5*G + R4)*G + R3)*G + R2)*G + R1)*G; end R; begin if X < ZERO then SGN := -ONE; Y := -X; else SGN := ONE; Y := X; end if; if Y > YMAX then NEW_LINE; PUT(" SIN CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY "); PUT(X); NEW_LINE; end if; N := INTEGER(Y * ONE_OVER_PI); XN := CONVERT_TO_FLOAT(N); if N mod 2 /= 0 then SGN := -SGN; end if; X1 := TRUNCATE(ABS(X)); X2 := ABS(X) - X1; F := ((X1 - XN*C1) + X2) - XN*C2; if ABS(F) < EPSILON then RESULT := F; else G := F * F; RESULT := F + F*R(G); end if; return (SGN * RESULT); end SIN; function COS(X : FLOAT) return FLOAT is SGN, Y : FLOAT; N : INTEGER; XN : FLOAT; F, G, X1, X2 : FLOAT; RESULT : FLOAT; YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2))); BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); C1 : constant FLOAT := 3.140625; C2 : constant FLOAT := 9.6765_35897_93E-4; function R(G : FLOAT) return FLOAT is R1 : constant FLOAT := -0.16666_66660_883; R2 : constant FLOAT := 0.83333_30720_556E-2; R3 : constant FLOAT := -0.19840_83282_313E-3; R4 : constant FLOAT := 0.27523_97106_775E-5; R5 : constant FLOAT := -0.23868_34640_601E-7; begin return ((((R5*G + R4)*G + R3)*G + R2)*G + R1)*G; end R; begin SGN := 1.0; Y := ABS(X) + PI_OVER_TWO; if Y > YMAX then NEW_LINE; PUT(" COS CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY "); PUT(X); NEW_LINE; end if; N := INTEGER(Y * ONE_OVER_PI); XN := CONVERT_TO_FLOAT(N); if N mod 2 /= 0 then SGN := -SGN; end if; XN := XN - 0.5; -- TO FORM COS INSTEAD OF SIN X1 := TRUNCATE(ABS(X)); X2 := ABS(X) - X1; F := ((X1 - XN*C1) + X2) - XN*C2; if ABS(F) < EPSILON then RESULT := F; else G := F * F; RESULT := F + F*R(G); end if; return (SGN * RESULT); end COS; function TAN(X : FLOAT) return FLOAT is SGN, Y : FLOAT; N : INTEGER; XN : FLOAT; F, G, X1, X2 : FLOAT; RESULT : FLOAT; YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2))) /2.0; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); C1 : constant FLOAT := 8#1.444#; C2 : constant FLOAT := 4.8382_67948_97E-4; function R(G : FLOAT) return FLOAT is P0 : constant FLOAT := 1.0; P1 : constant FLOAT := -0.11136_14403_566; P2 : constant FLOAT := 0.10751_54738_488E-2; Q0 : constant FLOAT := 1.0; Q1 : constant FLOAT := -0.44469_47720_281; Q2 : constant FLOAT := 0.15973_39213_300E-1; begin return ((P2*G + P1)*G*F + F) / (((Q2*G + Q1)*G +0.5) + 0.5); end R; begin Y := ABS(X); if Y > YMAX then NEW_LINE; PUT(" TAN CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY "); PUT(X); NEW_LINE; end if; N := INTEGER(X * TWO_OVER_PI); XN := CONVERT_TO_FLOAT(N); X1 := TRUNCATE(X); X2 := X - X1; F := ((X1 - XN*C1) + X2) - XN*C2; if ABS(F) < EPSILON then RESULT := F; else G := F * F; RESULT := R(G); end if; if N mod 2 = 0 then return RESULT; else return -1.0/RESULT; end if; end TAN; function COT(X : FLOAT) return FLOAT is SGN, Y : FLOAT; N : INTEGER; XN : FLOAT; F, G, X1, X2 : FLOAT; RESULT : FLOAT; YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2))) /2.0; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); EPSILON1 : FLOAT := 1.0/XMAX; C1 : constant FLOAT := 8#1.444#; C2 : constant FLOAT := 4.8382_67948_97E-4; function R(G : FLOAT) return FLOAT is P0 : constant FLOAT := 1.0; P1 : constant FLOAT := -0.11136_14403_566; P2 : constant FLOAT := 0.10751_54738_488E-2; Q0 : constant FLOAT := 1.0; Q1 : constant FLOAT := -0.44469_47720_281; Q2 : constant FLOAT := 0.15973_39213_300E-1; begin return ((P2*G + P1)*G*F + F) / (((Q2*G + Q1)*G +0.5) + 0.5); end R; begin Y := ABS(X); if Y < EPSILON1 then NEW_LINE; PUT(" COT CALLED WITH ARGUMENT TOO NEAR ZERO "); PUT(X); NEW_LINE; if X < 0.0 then return -XMAX; else return XMAX; end if; end if; if Y > YMAX then NEW_LINE; PUT(" COT CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY "); PUT(X); NEW_LINE; end if; N := INTEGER(X * TWO_OVER_PI); XN := CONVERT_TO_FLOAT(N); X1 := TRUNCATE(X); X2 := X - X1; F := ((X1 - XN*C1) + X2) - XN*C2; if ABS(F) < EPSILON then RESULT := F; else G := F * F; RESULT := R(G); end if; if N mod 2 /= 0 then return -RESULT; else return 1.0/RESULT; end if; end COT; function ASIN(X : FLOAT) return FLOAT is G, Y : FLOAT; RESULT : FLOAT; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); function R(G : FLOAT) return FLOAT is P1 : constant FLOAT := -0.27516_55529_0596E1; P2 : constant FLOAT := 0.29058_76237_4859E1; P3 : constant FLOAT := -0.59450_14419_3246; Q0 : constant FLOAT := -0.16509_93320_2424E2; Q1 : constant FLOAT := 0.24864_72896_9164E2; Q2 : constant FLOAT := -0.10333_86707_2113E2; Q3 : constant FLOAT := 1.0; begin return (((P3*G + P2)*G + P1)*G) / (((G + Q2)*G + Q1)*G + Q0); end R; begin Y := ABS(X); if Y > HALF then if Y > 1.0 then NEW_LINE; PUT(" ASIN CALLED FOR "); PUT(X); PUT(" (> 1) TRUNCATED TO 1, CONTINUED"); NEW_LINE; Y := 1.0; end if; G := ((0.5 - Y) + 0.5) / 2.0; Y := -2.0 * SQRT(G); RESULT := Y + Y * R(G); RESULT := (PI_OVER_FOUR + RESULT) + PI_OVER_FOUR; else if Y < EPSILON then RESULT := Y; else G := Y * Y; RESULT := Y + Y * R(G); end if; end if; if X < 0.0 then RESULT := -RESULT; end if; return RESULT; end ASIN; function ACOS(X : FLOAT) return FLOAT is G, Y : FLOAT; RESULT : FLOAT; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); function R(G : FLOAT) return FLOAT is P1 : constant FLOAT := -0.27516_55529_0596E1; P2 : constant FLOAT := 0.29058_76237_4859E1; P3 : constant FLOAT := -0.59450_14419_3246; Q0 : constant FLOAT := -0.16509_93320_2424E2; Q1 : constant FLOAT := 0.24864_72896_9164E2; Q2 : constant FLOAT := -0.10333_86707_2113E2; Q3 : constant FLOAT := 1.0; begin return (((P3*G + P2)*G + P1)*G) / (((G + Q2)*G + Q1)*G + Q0); end R; begin Y := ABS(X); if Y > HALF then if Y > 1.0 then NEW_LINE; PUT(" ACOS CALLED FOR "); PUT(X); PUT(" (> 1) TRUNCATED TO 1, CONTINUED"); NEW_LINE; Y := 1.0; end if; G := ((0.5 - Y) + 0.5) / 2.0; Y := -2.0 * SQRT(G); RESULT := Y + Y * R(G); if X < 0.0 then RESULT := (PI_OVER_TWO + RESULT) + PI_OVER_TWO; else RESULT := -RESULT; end if; else if Y < EPSILON then RESULT := Y; else G := Y * Y; RESULT := Y + Y * R(G); end if; if X < 0.0 then RESULT := (PI_OVER_FOUR + RESULT) + PI_OVER_FOUR; else RESULT := (PI_OVER_FOUR - RESULT) + PI_OVER_FOUR; end if; end if; return RESULT; end ACOS; function ATAN(X : FLOAT) return FLOAT is F, G : FLOAT; subtype REGION is INTEGER range 0..3; -- ########## N : REGION; RESULT : FLOAT; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); SQRT_3 : constant FLOAT := 1.73205_08075_68877_29353; SQRT_3_MINUS_1 : constant FLOAT := 0.73205_08075_68877_29353; TWO_MINUS_SQRT_3 : constant FLOAT := 0.26794_91924_31122_70647; function R(G : FLOAT) return FLOAT is P0 : constant FLOAT := -0.14400_83448_74E1; P1 : constant FLOAT := -0.72002_68488_98; Q0 : constant FLOAT := 0.43202_50389_19E1; Q1 : constant FLOAT := 0.47522_25845_99E1; Q2 : constant FLOAT := 1.0; begin return ((P1*G + P0)*G) / ((G + Q1)*G + Q0); end R; begin F := ABS(X); if F > 1.0 then F := 1.0 / F; N := 2; else N := 0; end if; if F > TWO_MINUS_SQRT_3 then F := (((SQRT_3_MINUS_1 * F - 0.5) - 0.5) + F) / (SQRT_3 + F); N := N + 1; end if; if ABS(F) < EPSILON then RESULT := F; else G := F * F; RESULT := F + F * R(G); end if; if N > 1 then RESULT := - RESULT; end if; case N is when 0 => RESULT := RESULT; when 1 => RESULT := PI_OVER_SIX + RESULT; when 2 => RESULT := PI_OVER_TWO + RESULT; when 3 => RESULT := PI_OVER_THREE + RESULT; end case; if X < 0.0 then RESULT := - RESULT; end if; return RESULT; end ATAN; function ATAN2(V, U : FLOAT) return FLOAT is X, RESULT : FLOAT; begin if U = 0.0 then if V = 0.0 then RESULT := 0.0; NEW_LINE; PUT(" ATAN2 CALLED WITH 0/0 RETURNED "); PUT(RESULT); NEW_LINE; elsif V > 0.0 then RESULT := PI_OVER_TWO; else RESULT := - PI_OVER_TWO; end if; else X := ABS(V/U); -- If underflow or overflow is detected, go to the exception RESULT := ATAN(X); if U < 0.0 then RESULT := PI - RESULT; end if; if V < 0.0 then RESULT := - RESULT; end if; end if; return RESULT; exception when NUMERIC_ERROR | CONSTRAINT_ERROR => if ABS(V) > ABS(U) then RESULT := PI_OVER_TWO; if V < 0.0 then RESULT := - RESULT; end if; else RESULT := 0.0; if U < 0.0 then RESULT := PI - RESULT; end if; end if; return RESULT; end ATAN2; function SINH(X : FLOAT) return FLOAT is G, W, Y, Z : FLOAT; RESULT : FLOAT; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); YBAR : FLOAT := EXP_LARGE; LN_V : FLOAT := 8#0.542714#; V_OVER_2_MINUS_1 : FLOAT := 0.13830_27787_96019_02638E-4; WMAX : FLOAT := YBAR - LN_V + 0.69; function R(G : FLOAT) return FLOAT is P0 : constant FLOAT := 0.10622_28883_7151E4; P1 : constant FLOAT := 0.31359_75645_6058E2; P2 : constant FLOAT := 0.34364_14035_8506; Q0 : constant FLOAT := 0.63733_73302_1822E4; Q1 : constant FLOAT := -0.13051_01250_9199E3; Q2 : constant FLOAT := 1.0; begin return (((P2*G + P1)*G + P0)*G) / ((G + Q1)*G + Q0); end R; begin Y := ABS(X); if Y <= 1.0 then if Y < EPSILON then RESULT := X; else G := X * X; RESULT := X + X * R(G); end if; else if Y <= YBAR then Z := EXP(Y); RESULT := (Z - 1.0/Z) / 2.0; else W := Y - LN_V; if W > WMAX then NEW_LINE; PUT(" SINH CALLED WITH TOO LARGE ARGUMENT "); PUT(X); PUT(" RETURN BIG"); NEW_LINE; W := WMAX; end if; Z := EXP(W); RESULT := Z + V_OVER_2_MINUS_1 * Z; end if; if X < 0.0 then RESULT := -RESULT; end if; end if; return RESULT; end SINH; function COSH(X : FLOAT) return FLOAT is G, W, Y, Z : FLOAT; RESULT : FLOAT; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); YBAR : FLOAT := EXP_LARGE; LN_V : FLOAT := 8#0.542714#; V_OVER_2_MINUS_1 : FLOAT := 0.13830_27787_96019_02638E-4; WMAX : FLOAT := YBAR - LN_V + 0.69; function R(G : FLOAT) return FLOAT is P0 : constant FLOAT := 0.10622_28883_7151E4; P1 : constant FLOAT := 0.31359_75645_6058E2; P2 : constant FLOAT := 0.34364_14035_8506; Q0 : constant FLOAT := 0.63733_73302_1822E4; Q1 : constant FLOAT := -0.13051_01250_9199E3; Q2 : constant FLOAT := 1.0; begin return (((P2*G + P1)*G + P0)*G) / ((G + Q1)*G + Q0); end R; begin Y := ABS(X); if Y <= YBAR then Z := EXP(Y); RESULT := (Z + 1.0/Z) / 2.0; else W := Y - LN_V; if W > WMAX then NEW_LINE; PUT(" COSH CALLED WITH TOO LARGE ARGUMENT "); PUT(X); PUT(" RETURN BIG"); NEW_LINE; W := WMAX; end if; Z := EXP(W); RESULT := Z + V_OVER_2_MINUS_1 * Z; end if; return RESULT; end COSH; function TANH(X : FLOAT) return FLOAT is G, W, Y, Z : FLOAT; RESULT : FLOAT; BETA : FLOAT := CONVERT_TO_FLOAT(IBETA); EPSILON : FLOAT := BETA ** (-IT/2); XBIG : FLOAT := (LOG(2.0) + CONVERT_TO_FLOAT(IT + 1) * LOG(BETA))/2.0; LN_3_OVER_2 : FLOAT := 0.54930_61443_34054_84570; function R(G : FLOAT) return FLOAT is P0 : constant FLOAT := -0.21063_95800_0245E2; P1 : constant FLOAT := -0.93363_47565_2401; Q0 : constant FLOAT := 0.63191_87401_5582E2; Q1 : constant FLOAT := 0.28077_65347_0471E2; Q2 : constant FLOAT := 1.0; begin return ((P1*G + P0)*G) / ((G + Q1)*G + Q0); end R; begin Y := ABS(X); if Y > XBIG then RESULT := 1.0; else if Y > LN_3_OVER_2 then RESULT := 0.5 - 1.0 / (EXP(Y + Y) + 1.0); RESULT := RESULT + RESULT; else if Y < EPSILON then RESULT := Y; else G := Y * Y; RESULT := Y + Y * R(G); end if; end if; end if; if X < 0.0 then RESULT := - RESULT; end if; return RESULT; end TANH; begin null; end TRIG_FUNCTIONS; --:::::::::: --out.bdy --:::::::::: -- ********************************** -- * * -- * Output_File * BODY -- * * -- ********************************** with Text_IO; package body Output_File is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version type FILE_OBJECT is record File : Text_IO.File_Type; Is_Open : BOOLEAN := false; Is_Output_Enabled : BOOLEAN := true; end record; -- .................................. -- . . -- . Already_Exists . BODY -- . . -- .................................. function Already_Exists ( File_Name : in STRING ) return BOOLEAN is --| Notes (none) File : Text_IO.File_Type; Result : BOOLEAN := true; begin -- Already_Exists begin Text_IO.Open(File, Text_IO.In_File, File_Name); Text_IO.Close(File); exception when others => Result := false; end; return Result; end Already_Exists; -- .................................. -- . . -- . Delete . BODY -- . . -- .................................. function Delete ( File_Name : in STRING ) return BOOLEAN is --| Notes (none) File : Text_IO.File_Type; Result : BOOLEAN := true; begin -- Delete begin if Already_Exists(File_Name) then Text_IO.Open(File, Text_IO.Out_File, File_Name); Text_IO.Delete(File); end if; exception when others => Result := false; end; return Result; end Delete; -- .................................. -- . . -- . Create . BODY -- . . -- .................................. procedure Create ( Id : in out File_Type; File_Name : in STRING ) is --| Notes (none) begin -- Create Id := new FILE_OBJECT; Text_IO.Create(Id.File, Text_IO.Out_File, File_Name); Id.Is_Open := true; Id.Is_Output_Enabled := true; exception -- Create -- Create when others => raise Cannot_Create_Output_File; end Create; -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Id : in out File_Type; Item : in CHARACTER ) is --| Notes (none) begin -- Put if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put(Id.File, Item); end if; exception -- Put -- Put when others => raise Write_Error; end Put; -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Id : in out File_Type; Item : in STRING ) is --| Notes (none) begin -- Put if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put(Id.File, Item); end if; exception -- Put -- Put when others => raise Write_Error; end Put; -- .................................. -- . . -- . Put_Line . BODY -- . . -- .................................. procedure Put_Line ( Id : in out File_Type; Item : in STRING ) is --| Notes (none) begin -- Put_Line if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put_Line(Id.File, Item); end if; exception -- Put_Line -- Put_Line when others => raise Write_Error; end Put_Line; -- .................................. -- . . -- . New_Line . BODY -- . . -- .................................. procedure New_Line ( Id : in out File_Type ) is --| Notes (none) begin -- New_Line if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.New_Line(Id.File); end if; exception -- New_Line -- New_Line when others => raise Write_Error; end New_Line; -- .................................. -- . . -- . New_Page . BODY -- . . -- .................................. procedure New_Page ( Id : in out File_Type ) is --| Notes (none) begin -- New_Page if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.New_Page(Id.File); end if; exception -- New_Page -- New_Page when others => raise Write_Error; end New_Page; -- .................................. -- . . -- . Enable_Output . BODY -- . . -- .................................. procedure Enable_Output ( Id : in out File_Type ) is --| Notes (none) begin -- Enable_Output Id.Is_Output_Enabled := true; end Enable_Output; -- .................................. -- . . -- . Disable_Output . BODY -- . . -- .................................. procedure Disable_Output ( Id : in out File_Type ) is --| Notes (none) begin -- Disable_Output Id.Is_Output_Enabled := false; end Disable_Output; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Id : in out File_Type ) is --| Notes (none) begin -- Close if Id.Is_Open then Text_IO.Close(Id.File); end if; end Close; end Output_File; --:::::::::: --permutat.bdy --:::::::::: package body Permutations_Class is ----------------------------- -- Basic algorithm from: -- "Programming in Modula-2" by Niklaus Wirth -- Chapter 14: Recursion ----------------------------- -- The procedure permutes the elements in the array ITEMS. -- actually it permutes their indicies and re-arranges the items -- within the list. The procedure does not care of any or all -- of the items in the list are equal (the same). ----------------------------- procedure Iterate_Through_Length_Factorial_Permutations (Of_Items : List_Type) is Buffer : List_Type (Of_Items'Range) := Of_Items; --------------------- procedure Permute (K_Th : Index_Type) is -- Swap successive elements of Buffer (Buffer'first .. K_th) -- and permute slices. This algorithm works backwords -- through the array (in reverse Buffer'range). Temp : Item_Type; begin if K_Th = Buffer'First then -- At the begining of the array. Done. Process result. Process (A_Permutation => Buffer); else --Decrement K and permute lower slice. Permute (Index_Type'Pred (K_Th)); -- Traverse lower slice. for I_Th in Buffer'First .. Index_Type'Pred (K_Th) loop -- swap K-th and I-th elements. Temp := Buffer (I_Th); Buffer (I_Th) := Buffer (K_Th); Buffer (K_Th) := Temp; -- Decrement K and permute lower slice. Permute (Index_Type'Pred (K_Th)); -- swap K-th and I-th elements back (restore). Temp := Buffer (I_Th); Buffer (I_Th) := Buffer (K_Th); Buffer (K_Th) := Temp; end loop; end if; end Permute; --------------------- begin -- iterate_through_length_factorial_permutations Permute (Buffer'Last); end Iterate_Through_Length_Factorial_Permutations; end Permutations_Class; --:::::::::: --priqueue.bdy --:::::::::: with UNCHECKED_DEALLOCATION; package body PRIORITIZED_QUEUE is -- ************************************************************************************* -- ** This software is part of the Clemson University Computer Science Department's ** -- ** Ada Software Repository, and is copyrighted (C) 1989 by Clemson University. ** -- ** Permission to copy without fee all or part of this software is granted, ** -- ** provided that the copies are not made or distributed for direct commercial ** -- ** advantage, and that this copyright notice is not deleted or modified. To ** -- ** copy otherwise, or to republish, requires a fee and/or specific permission. ** -- ** >> All bug reporters receive a free updated copy once the bug's corrected! << ** -- ** E-mail to: cpscada@citron.cs.clemson.edu or ...!gatech!hubcap!citron!cpscada. ** -- ************************************************************************************* -- type ENQUEUED_OBJECT is limited private; -- -- type PRIORITY_VALUE is (<>); -- -- with procedure ASSIGN (TARGET : in out ENQUEUED_OBJECT; -- SOURCE : in ENQUEUED_OBJECT) is <>; -- -- with function "=" (FIRST_OBJECT : in ENQUEUED_OBJECT; -- SECOND_OBJECT : in ENQUEUED_OBJECT) return BOOLEAN is <>; -- -- with procedure DESTROY (TARGETED_OBJECT : in out ENQUEUED_OBJECT) is <>; -- -- -- with procedure ":=" (TARGET_OBJECT : in out PRIORITY_VALUE; -- implicitly available... -- -- SOURCE_OBJECT : in PRIORITY_VALUE) is <>; -- -- with function "<" (FIRST_OBJECT : in PRIORITY_VALUE; -- SECOND_OBJECT : in PRIORITY_VALUE) return BOOLEAN is <>; -- -- -- with function "=" (FIRST_OBJECT : in PRIORITY_VALUE; -- implicitly available... -- -- SECOND_OBJECT : in PRIORITY_VALUE) return BOOLEAN is <>; -- -- Requested_Item_Does_Not_Exist_In_This_Priority_Queue : EXCEPTION; -- No_Items_Currently_Exist_In_This_Empty_Priority_Queue : EXCEPTION; -- -- type PRIORITY_QUEUE_NODE; -- -- type PRIORITY_QUEUE is access PRIORITY_QUEUE_NODE; -- -- -- requires O (n) space, where n is the NUMBER_OF_ITEMS in the queue... subtype PRIORITY_QUEUE_NODE_POINTER is PRIORITY_QUEUE; type PRIORITY_QUEUE_NODE is record ENQUEUED_ENTITY : ENQUEUED_OBJECT; ENTITY_PRIORITY : PRIORITY_VALUE; LEFTMOST_CHILD : PRIORITY_QUEUE_NODE_POINTER; SIBLING : PRIORITY_QUEUE_NODE_POINTER; end record; -- Our representation is as follows: A priority queue is a binomial forest (see CACM, Vol. 21, No. 4, pages 309-314). -- The type PRIORITY_QUEUE points to the root node of the smallest binomial tree in the forest. The SIBLING -- of this node points to the next larger tree in the forest. The sibling of the largest tree in the forest is null. -- At the root level, the SIBLING field points to the leftward sibling of a given binomial tree in a forest. At -- any other level, the SIBLING field points to the rightward sibling of a given child, in the traditional manner. -- -- This implementation has been carefully hand-optimized, and should be VERY fast, with little room for improvement. function NUMBER_OF_CHILDREN (TARGETED_NODE : PRIORITY_QUEUE_NODE_POINTER) return NATURAL is -- TARGETED_NODE must not be null... NUMBER_OF_CHILDREN_FOUND : NATURAL := 0; CURRENT_CHILD : PRIORITY_QUEUE_NODE_POINTER := TARGETED_NODE.LEFTMOST_CHILD; begin while (CURRENT_CHILD /= null) loop NUMBER_OF_CHILDREN_FOUND := NUMBER_OF_CHILDREN_FOUND + 1; CURRENT_CHILD := CURRENT_CHILD.SIBLING; end loop; return NUMBER_OF_CHILDREN_FOUND; end NUMBER_OF_CHILDREN; procedure ADD_WITH_CARRY (CURRENT_TREE : in out PRIORITY_QUEUE_NODE_POINTER; TREE_TO_ADD : in out PRIORITY_QUEUE_NODE_POINTER) is -- CURRENT_TREE must be the only pointer to the smallest tree in a given forest whose root has -- at least as many children as the root of the TREE_TO_ADD, subject to the constraint -- that the number of children associated with the root of CURRENT_TREE is not zero. CHILD_COUNTER : POSITIVE := 1; CHILD_COUNT_SCANNER : PRIORITY_QUEUE_NODE_POINTER; begin loop CHILD_COUNT_SCANNER := CURRENT_TREE.LEFTMOST_CHILD.SIBLING; -- we know that CURRENT_TREE must have while (CHILD_COUNTER /= 1) loop -- at least as many kids as TREE_TO_ADD... CHILD_COUNT_SCANNER := CHILD_COUNT_SCANNER.SIBLING; CHILD_COUNTER := CHILD_COUNTER - 1; end loop; exit when (CHILD_COUNT_SCANNER /= null); -- CURRENT_TREE has more kids than TREE_TO_ADD; room in forest... if (TREE_TO_ADD.ENTITY_PRIORITY < CURRENT_TREE.ENTITY_PRIORITY) then -- make TREE_TO_ADD a child of CURRENT_TREE... TREE_TO_ADD.SIBLING := CURRENT_TREE.LEFTMOST_CHILD; -- maintaining *rightward* links within a tree... CURRENT_TREE.LEFTMOST_CHILD := TREE_TO_ADD; TREE_TO_ADD := CURRENT_TREE; CURRENT_TREE := CURRENT_TREE.SIBLING; else -- make CURRENT_TREE a child of TREE_TO_ADD... TREE_TO_ADD.SIBLING := CURRENT_TREE.SIBLING; -- maintaining *leftward* links among trees in the forest... CURRENT_TREE.SIBLING := TREE_TO_ADD.LEFTMOST_CHILD; -- maintaining *rightward* links within a tree... TREE_TO_ADD.LEFTMOST_CHILD := CURRENT_TREE; CURRENT_TREE := TREE_TO_ADD.SIBLING; end if; exit when (CURRENT_TREE = null); -- we've reached the end of the forest... CHILD_COUNT_SCANNER := TREE_TO_ADD.LEFTMOST_CHILD.SIBLING; while (CHILD_COUNT_SCANNER /= null) loop -- count the children in the TREE_TO_ADD... CHILD_COUNTER := CHILD_COUNTER + 1; CHILD_COUNT_SCANNER := CHILD_COUNT_SCANNER.SIBLING; end loop; end loop; TREE_TO_ADD.SIBLING := CURRENT_TREE; -- maintaining *leftward* links among trees in the forest... CURRENT_TREE := TREE_TO_ADD; end ADD_WITH_CARRY; procedure INSERT_ITEM (QUEUE : in out PRIORITY_QUEUE; OBJECT : in ENQUEUED_OBJECT; PRIORITY : in PRIORITY_VALUE) is -- The QUEUE can safely handle multiple instances of a given (OBJECT, PRIORITY) pair. -- Works in O (log n) time, where n is the NUMBER_OF_ITEMS in the updated QUEUE. -- A series of consecutive initializing insertions uses O (n) time, where n is the number of insertions. NEW_ITEM : PRIORITY_QUEUE_NODE_POINTER := new PRIORITY_QUEUE_NODE; begin ASSIGN (NEW_ITEM.ENQUEUED_ENTITY, OBJECT); NEW_ITEM.ENTITY_PRIORITY := PRIORITY; if (QUEUE = null) then -- the new item becomes the only tree in the forest QUEUE := NEW_ITEM; elsif (QUEUE.LEFTMOST_CHILD /= null) then -- just insert the new smallest tree directly into the forest... NEW_ITEM.SIBLING := QUEUE; QUEUE := NEW_ITEM; else ADD_WITH_CARRY (QUEUE, NEW_ITEM); end if; end INSERT_ITEM; function ADD (FIRST_TREE : in PRIORITY_QUEUE_NODE_POINTER; SECOND_TREE : in PRIORITY_QUEUE_NODE_POINTER) return PRIORITY_QUEUE_NODE_POINTER is -- Merges the two trees into a single tree, returning the pointer to the unified tree. begin if (SECOND_TREE.ENTITY_PRIORITY < FIRST_TREE.ENTITY_PRIORITY) then SECOND_TREE.SIBLING := FIRST_TREE.LEFTMOST_CHILD; FIRST_TREE.LEFTMOST_CHILD := SECOND_TREE; return FIRST_TREE; else FIRST_TREE.SIBLING := SECOND_TREE.LEFTMOST_CHILD; SECOND_TREE.LEFTMOST_CHILD := FIRST_TREE; return SECOND_TREE; end if; end ADD; function SYNCHRONIZED_DOUBLE_ADD_WITH_CARRY (COMPLETE_SUBFOREST : in PRIORITY_QUEUE_NODE_POINTER; QUEUE : in PRIORITY_QUEUE_NODE_POINTER; STARTING_SIZE : in NATURAL ) return PRIORITY_QUEUE_NODE_POINTER is -- COMPLETE_SUBFOREST and QUEUE must point to identically sized trees; the subforests of which -- they are the smallest trees are added together, and a pointer to the resulting forest is returned. COMPLETE_SUBFOREST_POINTER : PRIORITY_QUEUE_NODE_POINTER := COMPLETE_SUBFOREST.SIBLING; QUEUE_POINTER : PRIORITY_QUEUE_NODE_POINTER := QUEUE.SIBLING; CARRY : PRIORITY_QUEUE_NODE_POINTER := ADD (COMPLETE_SUBFOREST, QUEUE); COMPLETE_SUBFOREST_COUNTER : NATURAL := STARTING_SIZE + 1; -- <= actually, these could both be QUEUE_COUNTER : NATURAL; -- <= POSITIVE, but we're eliminating NEXT_COMPLETE_SUBFOREST_TREE : PRIORITY_QUEUE_NODE_POINTER; -- the need for a machine-level NEXT_QUEUE_TREE : PRIORITY_QUEUE_NODE_POINTER; -- type conversion... RESULT : PRIORITY_QUEUE_NODE_POINTER; RESULT_POINTER : PRIORITY_QUEUE_NODE_POINTER; begin if (COMPLETE_SUBFOREST_POINTER /= null) and (QUEUE_POINTER /= null) then ADDER: loop QUEUE_COUNTER := NUMBER_OF_CHILDREN (QUEUE_POINTER); while (COMPLETE_SUBFOREST_COUNTER < QUEUE_COUNTER) loop NEXT_COMPLETE_SUBFOREST_TREE := COMPLETE_SUBFOREST_POINTER.SIBLING; -- span the gap, CARRY := ADD (COMPLETE_SUBFOREST_POINTER, CARRY); -- collapsing a COMPLETE_SUBFOREST_POINTER := NEXT_COMPLETE_SUBFOREST_TREE; -- prefix of the exit ADDER when (COMPLETE_SUBFOREST_POINTER = null); -- complete subforest COMPLETE_SUBFOREST_COUNTER := COMPLETE_SUBFOREST_COUNTER + 1; -- into CARRY... end loop; loop if (RESULT /= null) then RESULT_POINTER.SIBLING := CARRY; else RESULT := CARRY; end if; RESULT_POINTER := CARRY; NEXT_QUEUE_TREE := QUEUE_POINTER.SIBLING; NEXT_COMPLETE_SUBFOREST_TREE := COMPLETE_SUBFOREST_POINTER.SIBLING; CARRY := ADD (COMPLETE_SUBFOREST_POINTER, QUEUE_POINTER); -- traverse the path... QUEUE_POINTER := NEXT_QUEUE_TREE; COMPLETE_SUBFOREST_POINTER := NEXT_COMPLETE_SUBFOREST_TREE; exit ADDER when (COMPLETE_SUBFOREST_POINTER = null) or (QUEUE_POINTER = null); QUEUE_COUNTER := NUMBER_OF_CHILDREN (QUEUE_POINTER); COMPLETE_SUBFOREST_COUNTER := COMPLETE_SUBFOREST_COUNTER + 1; exit when (COMPLETE_SUBFOREST_COUNTER < QUEUE_COUNTER); end loop; end loop ADDER; end if; if (RESULT /= null) then RESULT_POINTER.SIBLING := CARRY; else RESULT := CARRY; end if; if (COMPLETE_SUBFOREST_POINTER = null) then CARRY.SIBLING := QUEUE_POINTER; else CARRY.SIBLING := COMPLETE_SUBFOREST_POINTER; end if; return RESULT; end SYNCHRONIZED_DOUBLE_ADD_WITH_CARRY; procedure REINSERT_CHILDREN (QUEUE : in out PRIORITY_QUEUE; FIRST_CHILD : in PRIORITY_QUEUE_NODE_POINTER) is TEMPORARY_FOREST : PRIORITY_QUEUE_NODE_POINTER := FIRST_CHILD; PREVIOUS_CHILD : PRIORITY_QUEUE_NODE_POINTER; NEXT_CHILD : PRIORITY_QUEUE_NODE_POINTER; TREE_NUMBER : NATURAL; begin if (TEMPORARY_FOREST /= null) then -- go through the child list and convert it to a *leftward*-sibling forest... loop NEXT_CHILD := TEMPORARY_FOREST.SIBLING; TEMPORARY_FOREST.SIBLING := PREVIOUS_CHILD; exit when (NEXT_CHILD = null); PREVIOUS_CHILD := TEMPORARY_FOREST; TEMPORARY_FOREST := NEXT_CHILD; end loop; end if; if (QUEUE = null) then QUEUE := TEMPORARY_FOREST; else NEXT_CHILD := TEMPORARY_FOREST; TREE_NUMBER := NUMBER_OF_CHILDREN (QUEUE); for SKIPPED_TREE in 2..TREE_NUMBER loop -- synchronize the two queues... PREVIOUS_CHILD := NEXT_CHILD; NEXT_CHILD := NEXT_CHILD.SIBLING; exit when (NEXT_CHILD = null); end loop; if (NEXT_CHILD = null) then -- concatenate the queues; no addition necessary!! PREVIOUS_CHILD.SIBLING := QUEUE; QUEUE := TEMPORARY_FOREST; elsif (TREE_NUMBER = 1) then QUEUE := SYNCHRONIZED_DOUBLE_ADD_WITH_CARRY (TEMPORARY_FOREST, QUEUE, 1); else PREVIOUS_CHILD.SIBLING := SYNCHRONIZED_DOUBLE_ADD_WITH_CARRY (NEXT_CHILD, QUEUE, TREE_NUMBER); QUEUE := TEMPORARY_FOREST; end if; end if; end REINSERT_CHILDREN; procedure PULL_OUT_HIGHEST_PRIORITY_OBJECT (MAXIMUM_PRIORITY_OBJECT : in out PRIORITY_QUEUE_NODE_POINTER; QUEUE : in out PRIORITY_QUEUE ) is TREE_PRECEDING_CURRENT_OBJECT : PRIORITY_QUEUE_NODE_POINTER; CURRENT_LOCATION : PRIORITY_QUEUE_NODE_POINTER; TREE_PRECEDING_CURRENT_LOCATION : PRIORITY_QUEUE_NODE_POINTER; begin if (QUEUE = null) then raise No_Items_Currently_Exist_In_This_Empty_Priority_Queue; end if; MAXIMUM_PRIORITY_OBJECT := QUEUE; CURRENT_LOCATION := QUEUE.SIBLING; while (CURRENT_LOCATION /= null) loop if (MAXIMUM_PRIORITY_OBJECT.ENTITY_PRIORITY < CURRENT_LOCATION.ENTITY_PRIORITY) then MAXIMUM_PRIORITY_OBJECT := CURRENT_LOCATION; TREE_PRECEDING_CURRENT_OBJECT := TREE_PRECEDING_CURRENT_LOCATION; end if; TREE_PRECEDING_CURRENT_LOCATION := CURRENT_LOCATION; CURRENT_LOCATION := CURRENT_LOCATION.SIBLING; end loop; if (TREE_PRECEDING_CURRENT_OBJECT = null) then QUEUE := MAXIMUM_PRIORITY_OBJECT.SIBLING; else TREE_PRECEDING_CURRENT_OBJECT.SIBLING := MAXIMUM_PRIORITY_OBJECT.SIBLING; end if; REINSERT_CHILDREN (QUEUE, MAXIMUM_PRIORITY_OBJECT.LEFTMOST_CHILD); end PULL_OUT_HIGHEST_PRIORITY_OBJECT; procedure ANNIHILATE is new UNCHECKED_DEALLOCATION (PRIORITY_QUEUE_NODE, PRIORITY_QUEUE_NODE_POINTER); procedure REMOVE_HIGHEST_PRIORITY_OBJECT (HIGHEST_PRIORITY_OBJECT : in out ENQUEUED_OBJECT; QUEUE : in out PRIORITY_QUEUE) is -- Works in O (log n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- Raises No_Items_Currently_Exist_In_This_Empty_Priority_Queue if the QUEUE is EMPTY. MAXIMUM_PRIORITY_OBJECT : PRIORITY_QUEUE_NODE_POINTER; begin PULL_OUT_HIGHEST_PRIORITY_OBJECT (MAXIMUM_PRIORITY_OBJECT, QUEUE); ASSIGN (HIGHEST_PRIORITY_OBJECT, MAXIMUM_PRIORITY_OBJECT.ENQUEUED_ENTITY); DESTROY (MAXIMUM_PRIORITY_OBJECT.ENQUEUED_ENTITY); ANNIHILATE (MAXIMUM_PRIORITY_OBJECT); end REMOVE_HIGHEST_PRIORITY_OBJECT; procedure REMOVE_HIGHEST_PRIORITY_OBJECT (HIGHEST_PRIORITY_OBJECT : in out ENQUEUED_OBJECT; PRIORITY_OF_THE_OBJECT : out PRIORITY_VALUE; QUEUE : in out PRIORITY_QUEUE) is -- Works in O (log n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- Raises No_Items_Currently_Exist_In_This_Empty_Priority_Queue if the QUEUE is EMPTY. MAXIMUM_PRIORITY_OBJECT : PRIORITY_QUEUE_NODE_POINTER; begin PULL_OUT_HIGHEST_PRIORITY_OBJECT (MAXIMUM_PRIORITY_OBJECT, QUEUE); ASSIGN (HIGHEST_PRIORITY_OBJECT, MAXIMUM_PRIORITY_OBJECT.ENQUEUED_ENTITY); PRIORITY_OF_THE_OBJECT := MAXIMUM_PRIORITY_OBJECT.ENTITY_PRIORITY; DESTROY (MAXIMUM_PRIORITY_OBJECT.ENQUEUED_ENTITY); ANNIHILATE (MAXIMUM_PRIORITY_OBJECT); end REMOVE_HIGHEST_PRIORITY_OBJECT; procedure INSERT_ITEM (QUEUE : in out PRIORITY_QUEUE; ITEM : in out PRIORITY_QUEUE_NODE_POINTER) is begin if (QUEUE = null) then -- the new item becomes the only tree in the forest QUEUE := ITEM; elsif (QUEUE.LEFTMOST_CHILD /= null) then -- just insert the new smallest tree directly into the forest... ITEM.SIBLING := QUEUE; QUEUE := ITEM; else ADD_WITH_CARRY (QUEUE, ITEM); end if; end INSERT_ITEM; procedure DELETE_ITEM (QUEUE : in out PRIORITY_QUEUE; OBJECT : in ENQUEUED_OBJECT; PRIORITY : in PRIORITY_VALUE) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- -- If multiple occurrences of the specified OBJECT and PRIORITY exist, the first -- such occurrence found will be deleted, and all others will be left undisturbed. -- PURGE_ITEM should be used if you wish to eliminate all such occurrences. -- -- If no occurrences of the specified OBJECT and PRIORITY exist, and the queue is -- not empty, raises Requested_Item_Does_Not_Exist_In_This_Priority_Queue. -- -- If the QUEUE is EMPTY, raises No_Items_Currently_Exist_In_This_Empty_Priority_Queue. DELETE_LOCATION : PRIORITY_QUEUE_NODE_POINTER; PREVIOUS_TREE : PRIORITY_QUEUE_NODE_POINTER; CURRENT_TREE : PRIORITY_QUEUE_NODE_POINTER := QUEUE; procedure LOCATE_AND_DELETE (SUBSTRUCTURE : in PRIORITY_QUEUE_NODE_POINTER) is begin if (SUBSTRUCTURE /= null) then if (OBJECT = SUBSTRUCTURE.ENQUEUED_ENTITY) and (PRIORITY = SUBSTRUCTURE.ENTITY_PRIORITY) then -- we found it!! DELETE_LOCATION := SUBSTRUCTURE; if (CURRENT_TREE = QUEUE) then QUEUE := QUEUE.SIBLING; else PREVIOUS_TREE.SIBLING := CURRENT_TREE.SIBLING; end if; if (DELETE_LOCATION.LEFTMOST_CHILD /= null) then REINSERT_CHILDREN (QUEUE, DELETE_LOCATION.LEFTMOST_CHILD); -- this pointer gets blown away later... end if; if (DELETE_LOCATION.SIBLING /= null) then REINSERT_CHILDREN (QUEUE, DELETE_LOCATION.SIBLING); -- and so does this one. end if; else LOCATE_AND_DELETE (SUBSTRUCTURE.LEFTMOST_CHILD); -- look for the desired item... if (DELETE_LOCATION = null) then -- still looking... LOCATE_AND_DELETE (SUBSTRUCTURE.SIBLING); end if; if (DELETE_LOCATION /= null) then -- we found it; start cutting subtrees... if (SUBSTRUCTURE.LEFTMOST_CHILD /= null) then -- cut the kids... if (SUBSTRUCTURE.LEFTMOST_CHILD /= DELETE_LOCATION) then REINSERT_CHILDREN (QUEUE, SUBSTRUCTURE.LEFTMOST_CHILD); end if; SUBSTRUCTURE.LEFTMOST_CHILD := null; end if; if (SUBSTRUCTURE.SIBLING /= null) then -- cut the rightward siblings... if (SUBSTRUCTURE.SIBLING /= DELETE_LOCATION) then REINSERT_CHILDREN (QUEUE, SUBSTRUCTURE.SIBLING); end if; SUBSTRUCTURE.SIBLING := null; end if; end if; end if; end if; end LOCATE_AND_DELETE; begin if (QUEUE = null) then raise No_Items_Currently_Exist_In_This_Empty_Priority_Queue; else loop -- over all trees in the queue... if (OBJECT = CURRENT_TREE.ENQUEUED_ENTITY) and (PRIORITY = CURRENT_TREE.ENTITY_PRIORITY) then -- success!! DELETE_LOCATION := CURRENT_TREE; if (CURRENT_TREE = QUEUE) then QUEUE := QUEUE.SIBLING; else PREVIOUS_TREE.SIBLING := CURRENT_TREE.SIBLING; end if; if (DELETE_LOCATION.LEFTMOST_CHILD /= null) then REINSERT_CHILDREN (QUEUE, DELETE_LOCATION.LEFTMOST_CHILD); end if; else LOCATE_AND_DELETE (CURRENT_TREE.LEFTMOST_CHILD); if (DELETE_LOCATION /= null) then if (CURRENT_TREE.LEFTMOST_CHILD /= null) then -- put the last remaining child up for adoption... if (CURRENT_TREE.LEFTMOST_CHILD /= DELETE_LOCATION) then -- unless it's slated for execution. INSERT_ITEM (QUEUE, CURRENT_TREE.LEFTMOST_CHILD); end if; CURRENT_TREE.LEFTMOST_CHILD := null; end if; CURRENT_TREE.SIBLING := null; INSERT_ITEM (QUEUE, CURRENT_TREE); -- everything except the deleted item is now back in the queue. end if; end if; exit when (DELETE_LOCATION /= null); PREVIOUS_TREE := CURRENT_TREE; CURRENT_TREE := CURRENT_TREE.SIBLING; exit when (CURRENT_TREE = null); end loop; if (DELETE_LOCATION /= null) then DESTROY (DELETE_LOCATION.ENQUEUED_ENTITY); ANNIHILATE (DELETE_LOCATION); -- here is where those two pointers get blown away. else raise Requested_Item_Does_Not_Exist_In_This_Priority_Queue; end if; end if; end DELETE_ITEM; procedure MERGE (TARGET_QUEUE : in out PRIORITY_QUEUE; SOURCE_QUEUE : in PRIORITY_QUEUE) is -- The objects which were in the SOURCE_QUEUE are merged into the TARGET_QUEUE; the SOURCE_QUEUE -- is left EMPTY. Works in O (log n) time, where n is the NUMBER_OF_ITEMS in the newly merged queue. TARGET_QUEUE_POINTER : PRIORITY_QUEUE_NODE_POINTER := TARGET_QUEUE; SOURCE_QUEUE_POINTER : PRIORITY_QUEUE_NODE_POINTER := SOURCE_QUEUE; CARRY : PRIORITY_QUEUE_NODE_POINTER; NEXT_TARGET_QUEUE_POINTER : PRIORITY_QUEUE_NODE_POINTER; NEXT_SOURCE_QUEUE_POINTER : PRIORITY_QUEUE_NODE_POINTER; TARGET_QUEUE_COUNTER : NATURAL := 0; SOURCE_QUEUE_COUNTER : NATURAL := 0; CARRY_COUNTER : NATURAL; -- actually, this could be a POSITIVE, but we're -- eliminating the need for a machine-level type conversion. RESULT : PRIORITY_QUEUE_NODE_POINTER; RESULT_POINTER : PRIORITY_QUEUE_NODE_POINTER; procedure STORE_RESULT (INTERMEDIATE_RESULT : in PRIORITY_QUEUE_NODE_POINTER) is begin if (RESULT /= null) then RESULT_POINTER.SIBLING := INTERMEDIATE_RESULT; else RESULT := INTERMEDIATE_RESULT; end if; RESULT_POINTER := INTERMEDIATE_RESULT; end STORE_RESULT; procedure RESOLVE_REMAINS (QUEUE_POINTER : in out PRIORITY_QUEUE_NODE_POINTER; QUEUE_COUNTER : in out NATURAL ) is -- QUEUE_POINTER is not null, and QUEUE_COUNTER tells us how many children -- are in the first tree in the subforest pointed to by QUEUE_POINTER. begin if (CARRY = null) then if (RESULT = null) then RESULT := QUEUE_POINTER; else RESULT_POINTER.SIBLING := QUEUE_POINTER; end if; elsif (QUEUE_COUNTER < CARRY_COUNTER) then STORE_RESULT (QUEUE_POINTER); RESULT_POINTER.SIBLING := CARRY; elsif (CARRY_COUNTER < QUEUE_COUNTER) then STORE_RESULT (CARRY); RESULT_POINTER.SIBLING := QUEUE_POINTER; else -- QUEUE_COUNTER = CARRY_COUNTER... CLEANUP: loop NEXT_TARGET_QUEUE_POINTER := QUEUE_POINTER.SIBLING; -- squeezing a bit more usefulness out of CARRY := ADD (CARRY, QUEUE_POINTER); -- NEXT_TARGET_QUEUE_POINTER, which is exit CLEANUP when (NEXT_TARGET_QUEUE_POINTER = null); -- otherwise no longer in use at this point... CARRY_COUNTER := QUEUE_COUNTER + 1; QUEUE_POINTER := NEXT_TARGET_QUEUE_POINTER; QUEUE_COUNTER := NUMBER_OF_CHILDREN (QUEUE_POINTER); if (CARRY_COUNTER < QUEUE_COUNTER) then CARRY.SIBLING := QUEUE_POINTER; exit CLEANUP; end if; end loop CLEANUP; if (RESULT /= null) then RESULT_POINTER.SIBLING := CARRY; else RESULT := CARRY; end if; end if; end RESOLVE_REMAINS; begin if (TARGET_QUEUE_POINTER /= null) and (SOURCE_QUEUE_POINTER /= null) then ADDER: loop if (CARRY = null) then if (TARGET_QUEUE_COUNTER < SOURCE_QUEUE_COUNTER) then STORE_RESULT (TARGET_QUEUE_POINTER); TARGET_QUEUE_POINTER := TARGET_QUEUE_POINTER.SIBLING; exit ADDER when (TARGET_QUEUE_POINTER = null); TARGET_QUEUE_COUNTER := NUMBER_OF_CHILDREN (TARGET_QUEUE_POINTER); else -- SOURCE_QUEUE_COUNTER < TARGET_QUEUE_COUNTER... STORE_RESULT (SOURCE_QUEUE_POINTER); SOURCE_QUEUE_POINTER := SOURCE_QUEUE_POINTER.SIBLING; exit ADDER when (SOURCE_QUEUE_POINTER = null); SOURCE_QUEUE_COUNTER := NUMBER_OF_CHILDREN (SOURCE_QUEUE_POINTER); end if; else -- CARRY /= null... if (TARGET_QUEUE_COUNTER = SOURCE_QUEUE_COUNTER) then STORE_RESULT (CARRY); NEXT_TARGET_QUEUE_POINTER := TARGET_QUEUE_POINTER.SIBLING; NEXT_SOURCE_QUEUE_POINTER := SOURCE_QUEUE_POINTER.SIBLING; CARRY := ADD (TARGET_QUEUE_POINTER, SOURCE_QUEUE_POINTER); CARRY_COUNTER := TARGET_QUEUE_COUNTER + 1; TARGET_QUEUE_POINTER := NEXT_TARGET_QUEUE_POINTER; SOURCE_QUEUE_POINTER := NEXT_SOURCE_QUEUE_POINTER; if (TARGET_QUEUE_POINTER /= null) then TARGET_QUEUE_COUNTER := NUMBER_OF_CHILDREN (TARGET_QUEUE_POINTER); end if; if (SOURCE_QUEUE_POINTER /= null) then SOURCE_QUEUE_COUNTER := NUMBER_OF_CHILDREN (SOURCE_QUEUE_POINTER); end if; exit ADDER when (TARGET_QUEUE_POINTER = null) or (SOURCE_QUEUE_POINTER = null); elsif (TARGET_QUEUE_COUNTER < SOURCE_QUEUE_COUNTER) then if (TARGET_QUEUE_COUNTER = CARRY_COUNTER) then NEXT_TARGET_QUEUE_POINTER := TARGET_QUEUE_POINTER.SIBLING; CARRY := ADD (TARGET_QUEUE_POINTER, CARRY); CARRY_COUNTER := TARGET_QUEUE_COUNTER + 1; TARGET_QUEUE_POINTER := NEXT_TARGET_QUEUE_POINTER; else -- CARRY_COUNTER < TARGET_QUEUE_COUNTER... STORE_RESULT (CARRY); RESULT_POINTER.SIBLING := TARGET_QUEUE_POINTER; RESULT_POINTER := TARGET_QUEUE_POINTER; TARGET_QUEUE_POINTER := TARGET_QUEUE_POINTER.SIBLING; end if; exit ADDER when (TARGET_QUEUE_POINTER = null); TARGET_QUEUE_COUNTER := NUMBER_OF_CHILDREN (TARGET_QUEUE_POINTER); else -- SOURCE_QUEUE_COUNTER < TARGET_QUEUE_COUNTER... if (SOURCE_QUEUE_COUNTER = CARRY_COUNTER) then NEXT_SOURCE_QUEUE_POINTER := SOURCE_QUEUE_POINTER.SIBLING; CARRY := ADD (SOURCE_QUEUE_POINTER, CARRY); CARRY_COUNTER := SOURCE_QUEUE_COUNTER + 1; SOURCE_QUEUE_POINTER := NEXT_SOURCE_QUEUE_POINTER; else -- CARRY_COUNTER < SOURCE_QUEUE_COUNTER... STORE_RESULT (CARRY); RESULT_POINTER.SIBLING := SOURCE_QUEUE_POINTER; RESULT_POINTER := SOURCE_QUEUE_POINTER; SOURCE_QUEUE_POINTER := SOURCE_QUEUE_POINTER.SIBLING; end if; exit ADDER when (SOURCE_QUEUE_POINTER = null); SOURCE_QUEUE_COUNTER := NUMBER_OF_CHILDREN (SOURCE_QUEUE_POINTER); end if; end if; end loop ADDER; end if; if (TARGET_QUEUE_POINTER = null) and (SOURCE_QUEUE_POINTER /= null) then RESOLVE_REMAINS (SOURCE_QUEUE_POINTER, SOURCE_QUEUE_COUNTER); elsif (SOURCE_QUEUE_POINTER = null) and (TARGET_QUEUE_POINTER /= null) then RESOLVE_REMAINS (TARGET_QUEUE_POINTER, TARGET_QUEUE_COUNTER); elsif (RESULT /= null) then RESULT_POINTER.SIBLING := CARRY; else RESULT := CARRY; end if; TARGET_QUEUE := RESULT; end MERGE; generic with function TO_BE_PURGED (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is <>; with function OK_TO_DESCEND (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is <>; procedure PURGE_QUEUE (QUEUE : in out PRIORITY_QUEUE); procedure PURGE_QUEUE (QUEUE : in out PRIORITY_QUEUE) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- -- Will terminate normally, even if the QUEUE was already EMPTY... PREVIOUS_TREE : PRIORITY_QUEUE_NODE_POINTER; CURRENT_TREE : PRIORITY_QUEUE_NODE_POINTER := QUEUE; NEXT_TREE : PRIORITY_QUEUE_NODE_POINTER; SUBTREE_HIT : BOOLEAN; ROOT_HIT : BOOLEAN; DEBRIS : PRIORITY_QUEUE; procedure PURGE_SUBTREE (SUBSTRUCTURE : in out PRIORITY_QUEUE_NODE_POINTER) is begin if (SUBSTRUCTURE /= null) and then OK_TO_DESCEND (SUBSTRUCTURE) then PURGE_SUBTREE (SUBSTRUCTURE.LEFTMOST_CHILD); PURGE_SUBTREE (SUBSTRUCTURE.SIBLING); if TO_BE_PURGED (SUBSTRUCTURE) then if not SUBTREE_HIT then SUBTREE_HIT := True; REINSERT_CHILDREN (DEBRIS, SUBSTRUCTURE.LEFTMOST_CHILD); REINSERT_CHILDREN (DEBRIS, SUBSTRUCTURE.SIBLING); end if; DESTROY (SUBSTRUCTURE.ENQUEUED_ENTITY); ANNIHILATE (SUBSTRUCTURE); elsif SUBTREE_HIT then INSERT_ITEM (DEBRIS, SUBSTRUCTURE); SUBSTRUCTURE := null; end if; end if; end PURGE_SUBTREE; begin while (CURRENT_TREE /= null) loop -- over all trees in the queue... ROOT_HIT := TO_BE_PURGED (CURRENT_TREE); SUBTREE_HIT := False; PURGE_SUBTREE (CURRENT_TREE.LEFTMOST_CHILD); if ROOT_HIT or SUBTREE_HIT then if (CURRENT_TREE = QUEUE) then QUEUE := QUEUE.SIBLING; NEXT_TREE := QUEUE; else PREVIOUS_TREE.SIBLING := CURRENT_TREE.SIBLING; NEXT_TREE := PREVIOUS_TREE.SIBLING; end if; if ROOT_HIT then if (CURRENT_TREE.LEFTMOST_CHILD /= null) then REINSERT_CHILDREN (DEBRIS, CURRENT_TREE.LEFTMOST_CHILD); end if; DESTROY (CURRENT_TREE.ENQUEUED_ENTITY); ANNIHILATE (CURRENT_TREE); else CURRENT_TREE.SIBLING := null; INSERT_ITEM (DEBRIS, CURRENT_TREE); end if; CURRENT_TREE := NEXT_TREE; else PREVIOUS_TREE := CURRENT_TREE; CURRENT_TREE := CURRENT_TREE.SIBLING; end if; end loop; MERGE (QUEUE, DEBRIS); end PURGE_QUEUE; procedure PURGE_ITEM (QUEUE : in out PRIORITY_QUEUE; OBJECT : in ENQUEUED_OBJECT) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- -- Will terminate normally, even if the QUEUE was already EMPTY... function TO_BE_PURGED (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return (NODE.ENQUEUED_ENTITY = OBJECT); end TO_BE_PURGED; function OK_TO_DESCEND (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return True; end OK_TO_DESCEND; procedure PURGE is new PURGE_QUEUE; begin PURGE (QUEUE); end PURGE_ITEM; procedure PURGE_ITEM (QUEUE : in out PRIORITY_QUEUE; OBJECT : in ENQUEUED_OBJECT; PRIORITY : in PRIORITY_VALUE) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- -- Will terminate normally, even if the QUEUE was already EMPTY... function TO_BE_PURGED (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return ( (NODE.ENTITY_PRIORITY = PRIORITY) and then (NODE.ENQUEUED_ENTITY = OBJECT) ); end TO_BE_PURGED; function OK_TO_DESCEND (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return ( not (PRIORITY < NODE.ENTITY_PRIORITY) ); end OK_TO_DESCEND; procedure PURGE is new PURGE_QUEUE; begin PURGE (QUEUE); end PURGE_ITEM; procedure PURGE_PRIORITY (QUEUE : in out PRIORITY_QUEUE; PRIORITY : in PRIORITY_VALUE) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- -- Will terminate normally, even if the QUEUE was already EMPTY... function TO_BE_PURGED (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return (NODE.ENTITY_PRIORITY = PRIORITY); end TO_BE_PURGED; function OK_TO_DESCEND (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return ( not (PRIORITY < NODE.ENTITY_PRIORITY) ); end OK_TO_DESCEND; procedure PURGE is new PURGE_QUEUE; begin PURGE (QUEUE); end PURGE_PRIORITY; procedure PURGE_PRIORITY_RANGE (QUEUE : in out PRIORITY_QUEUE; FROM_PRIORITY : in PRIORITY_VALUE; TO_PRIORITY : in PRIORITY_VALUE) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS originally in the QUEUE. -- -- Will terminate normally, even if the QUEUE was already EMPTY... function TO_BE_PURGED (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return ( (NODE.ENTITY_PRIORITY = FROM_PRIORITY) or (NODE.ENTITY_PRIORITY = TO_PRIORITY) or ( (FROM_PRIORITY < NODE.ENTITY_PRIORITY) and (NODE.ENTITY_PRIORITY < TO_PRIORITY) ) ); end TO_BE_PURGED; function OK_TO_DESCEND (NODE : in PRIORITY_QUEUE_NODE_POINTER) return BOOLEAN is begin return ( not (TO_PRIORITY < NODE.ENTITY_PRIORITY) ); end OK_TO_DESCEND; procedure PURGE is new PURGE_QUEUE; begin PURGE (QUEUE); end PURGE_PRIORITY_RANGE; procedure CHANGE_PRIORITY (QUEUE : in out PRIORITY_QUEUE; OBJECT : in ENQUEUED_OBJECT; OLD_PRIORITY : in PRIORITY_VALUE; NEW_PRIORITY : in PRIORITY_VALUE) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE. -- -- If multiple occurrences of the specified OBJECT and OLD_PRIORITY exist in the QUEUE, -- the first such occurrence found will be modified, and all others will be left undisturbed. -- -- If no occurrences of the specified OBJECT and OLD_PRIORITY exist in the QUEUE, and the QUEUE is not EMPTY, -- raises Requested_Item_Does_Not_Exist_In_This_Priority_Queue. -- -- If the QUEUE is EMPTY, raises No_Items_Currently_Exist_In_This_Empty_Priority_Queue. begin DELETE_ITEM (QUEUE, OBJECT, OLD_PRIORITY); -- O (n) INSERT_ITEM (QUEUE, OBJECT, NEW_PRIORITY); -- O (log n) end CHANGE_PRIORITY; function EMPTY (QUEUE : in PRIORITY_QUEUE) return BOOLEAN is -- Works in O (1) time. begin return (QUEUE = null); end EMPTY; function NUMBER_OF_ITEMS (QUEUE : in PRIORITY_QUEUE) return NATURAL is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE. NUMBER_OF_ITEMS_FOUND : NATURAL := 0; procedure FIND_ITEMS (SUBSTRUCTURE : in PRIORITY_QUEUE_NODE_POINTER) is begin if (SUBSTRUCTURE /= null) then NUMBER_OF_ITEMS_FOUND := NUMBER_OF_ITEMS_FOUND + 1; FIND_ITEMS (SUBSTRUCTURE.SIBLING); FIND_ITEMS (SUBSTRUCTURE.LEFTMOST_CHILD); end if; end FIND_ITEMS; begin FIND_ITEMS (QUEUE); return NUMBER_OF_ITEMS_FOUND; end NUMBER_OF_ITEMS; procedure DESTROY (TARGETED_OBJECT : in out PRIORITY_QUEUE) is -- Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE. procedure RECURSIVELY_DESTROY (TARGETED_OBJECT : in out PRIORITY_QUEUE_NODE_POINTER) is begin if (TARGETED_OBJECT /= null) then DESTROY (TARGETED_OBJECT.ENQUEUED_ENTITY); RECURSIVELY_DESTROY (TARGETED_OBJECT.SIBLING); RECURSIVELY_DESTROY (TARGETED_OBJECT.LEFTMOST_CHILD); ANNIHILATE (TARGETED_OBJECT); end if; end RECURSIVELY_DESTROY; begin RECURSIVELY_DESTROY (TARGETED_OBJECT); end DESTROY; procedure ASSIGN (TARGET_OBJECT : in out PRIORITY_QUEUE; SOURCE_OBJECT : in PRIORITY_QUEUE) is -- Works in O (n) time, where n is the maximum of the NUMBER_OF_ITEMS to be destroyed in the TARGET_OBJECT -- and the NUMBER_OF_ITEMS in the SOURCE_OBJECT. procedure COPY_STRUCTURE (TARGET_OBJECT : in out PRIORITY_QUEUE_NODE_POINTER; SOURCE_OBJECT : in PRIORITY_QUEUE_NODE_POINTER) is begin if (SOURCE_OBJECT /= null) then TARGET_OBJECT := new PRIORITY_QUEUE_NODE; ASSIGN (TARGET_OBJECT.ENQUEUED_ENTITY, SOURCE_OBJECT.ENQUEUED_ENTITY); TARGET_OBJECT.ENTITY_PRIORITY := SOURCE_OBJECT.ENTITY_PRIORITY; COPY_STRUCTURE (TARGET_OBJECT.SIBLING, SOURCE_OBJECT.SIBLING); COPY_STRUCTURE (TARGET_OBJECT.LEFTMOST_CHILD, SOURCE_OBJECT.LEFTMOST_CHILD); end if; end COPY_STRUCTURE; begin DESTROY (TARGET_OBJECT); COPY_STRUCTURE (TARGET_OBJECT, SOURCE_OBJECT); end ASSIGN; procedure DESTROY (TARGETED_OBJECT : in out POINTER_TO_PRIORITY_QUEUE) is -- Unlike UNCHECKED_DEALLOCATION, this procedure will properly destroy the PRIORITY_QUEUE being pointed to. -- Works in O (n) time, where n is the NUMBER_OF_ITEMS in the PRIORITY_QUEUE being pointed to. procedure ANNIHILATE is new UNCHECKED_DEALLOCATION (PRIORITY_QUEUE, POINTER_TO_PRIORITY_QUEUE); begin if (TARGETED_OBJECT /= null) then DESTROY (TARGETED_OBJECT.all); ANNIHILATE (TARGETED_OBJECT); end if; end DESTROY; end PRIORITIZED_QUEUE; --:::::::::: --qsort.bdy --:::::::::: with TEXT_IO; procedure QSORT (A : in out ROW) is procedure QSORT_INTERNAL (L, R : INDEX) is I, J : INDEX; X : ITEM; TEMP : ITEM; begin I := L; J := R; X := A (INDEX'VAL ((INDEX'POS (L) + INDEX'POS (R)) / 2)); MAIN: loop while A (I) < X loop I := INDEX'SUCC (I); end loop; while X < A (J) loop J := INDEX'PRED (J); end loop; if I <= J then TEMP := A(I); A(I) := A(J); A(J) := TEMP; begin I := INDEX'SUCC (I); J := INDEX'PRED (J); exception when CONSTRAINT_ERROR => null; -- necessary to avoid exception raising end; end if; exit when I > J; end loop MAIN; if L < J then QSORT_INTERNAL (L, J); end if; if I < R then QSORT_INTERNAL (I, R); end if; end QSORT_INTERNAL; begin QSORT_INTERNAL (A'FIRST, A'LAST); exception when others => TEXT_IO.PUT_LINE ("QSORT: Exception raised"); end QSORT; --:::::::::: --random.bdy --:::::::::: with CALENDAR; package body RANDOM is X : INTEGER; Y : INTEGER; Z : INTEGER; --============================================================= function CONVERT_TO_FLOAT(ITEM : in INTEGER) return FLOAT is -- This function is necessary for some optimizing compilers -- in order to prevent expressions like FLOAT(INTEGER(FLOAT)) -- from being optimized away begin return FLOAT(ITEM); end CONVERT_TO_FLOAT; --============================================================= procedure SEED is -- Generate seed values for X, Y, and Z using Package CALENDAR DAY_MONTH : FLOAT; SECONDS : FLOAT; HUNDREDS : FLOAT; begin SECONDS := FLOAT(CALENDAR.SECONDS(CALENDAR.CLOCK)); HUNDREDS := (SECONDS/2.88) - CONVERT_TO_FLOAT(INTEGER((SECONDS/2.88) - 0.5)); DAY_MONTH := FLOAT(CALENDAR.DAY(CALENDAR.CLOCK) * CALENDAR.MONTH(CALENDAR.CLOCK)); X := INTEGER(SECONDS/2.88); Y := INTEGER(HUNDREDS * 30000.0); Z := INTEGER(DAY_MONTH/372.0 * SECONDS * 30000.0); end SEED; --============================================================= function NUMBER return FLOAT is -- This rectangular random number routine is adapted from a report -- "A Pseudo-Random Number Generator" by B. A. Wichmann and I. D. Hill -- NPL Report DNACS XX (to be published) -- In this version, it is suitable for machines supporting -- INTEGER at only 16 bits and is portable in Ada W : FLOAT; begin X := 171 * (X mod 177) - 2 * (X / 177); -- Used to be: X := 171 * (X mod 177 - 177) - 2 * (X / 177); if X < 0 then X := X + 30269; end if; Y := 172 * (Y mod 176) - 35 * (Y / 176); if Y < 0 then Y := Y + 30307; end if; Z := 170 * (Z mod 178) - 63 * (Z / 178); if Z < 0 then Z := Z + 30323; end if; W := FLOAT(X) / 30269.0 + FLOAT(Y) / 30307.0 + FLOAT(Z) / 30323.0; return W - CONVERT_TO_FLOAT(INTEGER(W - 0.5)); end NUMBER; --============================================================= begin SEED; -- Initialize random number generator end RANDOM; --:::::::::: --scanners.bdy --:::::::::: package body scanners is --| Scan tokens from strings ---------------------------------------------------------------------------- -- Local function specs: function is_Space(C: Character) return boolean; --| Return True iff C is a space or tab. pragma inline(is_Space); ---------------------------------------------------------------------------- procedure start_Scanner( --| Initialize a scanner Scanner: in out Scanner_Type; --| Scanner to be initialized S: in string; --| String to be scanned Last: in natural --| Last scannable character in S. ) is begin Scanner.Index := S'First; Scanner.Max_Index := Last; Scanner.First := 1; Scanner.Last := 0; Scanner.Length := 0; end start_Scanner; ---------------------------------------------------------------------------- function is_Empty( --| Return False if Scanner can scan more characters Scanner: in Scanner_Type ) return boolean is begin return Scanner.Index > Scanner.Max_Index; end is_Empty; ---------------------------------------------------------------------------- function is_Alpha( --| Check for alphabetic character Scanner: in scanner_Type; S: in string ) return boolean is begin return Scanner.Index <= scanner.Max_Index and then (S(Scanner.Index) in 'a'..'z' or else S(Scanner.Index) in 'A'..'Z'); end is_Alpha; ---------------------------------------------------------------------------- function is_Digit( --| Check for start of unsigned number Scanner: in scanner_Type; S: in string ) return boolean is begin return Scanner.Index <= scanner.Max_Index and then S(Scanner.Index) in '0'..'9'; end is_Digit; ---------------------------------------------------------------------------- function is_Sign( --| Check for '+' or '-' Scanner: in scanner_Type; S: in string ) return boolean is begin return Scanner.Index <= scanner.Max_Index and then (S(Scanner.Index) = '+' or else S(Scanner.Index) = '-'); end is_Sign; ---------------------------------------------------------------------------- function is_Digit_or_Sign( --| Check for start of optionally signed number Scanner: in scanner_Type; S: in string ) return boolean is begin return Scanner.Index <= scanner.Max_Index and then (S(Scanner.Index) in '0'..'9' or else S(Scanner.Index) = '+' or else S(Scanner.Index) = '-'); end is_Digit_or_Sign; ---------------------------------------------------------------------------- procedure skip_Blanks( --| Skip leading blanks in S Scanner: in out Scanner_Type; --| Scanner to be updated S: in string --| String being scanned ) is begin Scanner.First := Scanner.Index; Scanner.Length := 0; if Scanner.Index <= Scanner.Max_Index then while is_Space(S(Scanner.Index)) loop Scanner.Index := Scanner.Index + 1; exit when Scanner.Index > Scanner.Max_Index; end loop; Scanner.Length := Scanner.Index - Scanner.First; end if; end skip_Blanks; ---------------------------------------------------------------------------- procedure trim_blanks( Scanner: in out Scanner_Type; S: in string ) is begin while Scanner.First < Scanner.Last and then is_Space(S(Scanner.First)) loop Scanner.First := Scanner.First + 1; end loop; while Scanner.Last >= Scanner.First and then is_Space(S(Scanner.Last)) loop Scanner.Last := Scanner.Last - 1; end loop; Scanner.Length := Scanner.Last - Scanner.First + 1; end trim_Blanks; ---------------------------------------------------------------------------- procedure scan_Until( --| Scan until C is found Scanner: in out Scanner_Type; S: in string; C: in character ) is Index: natural := Scanner.Index; begin Scanner.Length := 0; if Index <= Scanner.Max_Index then while S(Index) /= C loop Index := Index + 1; if Index > Scanner.Max_Index then -- Didn't find C return; end if; end loop; Scanner.First := Scanner.Index; -- First character scanned Scanner.Length := Index - Scanner.First; Scanner.Last := Index - 1; Scanner.Index := Index; end if; end scan_Until; ---------------------------------------------------------------------------- procedure scan_Word( --| Scan past a sequence of non-blank characters Scanner: in out Scanner_Type; S: in string ) is begin Scanner.First := Scanner.Index; Scanner.Last := Scanner.First - 1; Scanner.Length := 0; if Scanner.Index <= Scanner.Max_Index then while not is_Space(S(Scanner.Index)) loop Scanner.Index := Scanner.Index + 1; exit when Scanner.Index > Scanner.Max_Index; end loop; Scanner.Length := Scanner.Index - Scanner.First; Scanner.Last := Scanner.Index - 1; end if; end scan_Word; ---------------------------------------------------------------------------- procedure scan_Number( Scanner: in out scanner_Type; S: in string ) is begin Scanner.First := Scanner.Index; if Scanner.Index <= Scanner.Max_Index then if S(Scanner.Index) = '-' or else S(Scanner.Index) = '+' then Scanner.Index := Scanner.Index + 1; end if; while Scanner.Index <= Scanner.Max_Index and then S(Scanner.Index) in '0'..'9' loop Scanner.Index := Scanner.Index + 1; end loop; end if; Scanner.Length := Scanner.Index - Scanner.First; Scanner.Last := Scanner.Index - 1; end scan_Number; ---------------------------------------------------------------------------- procedure scan_Delimited( --| Scan string delimited by a single character Scanner: in out scanner_Type; S: in string ) is quote: character; begin Scanner.First := Scanner.Index; if Scanner.Index <= Scanner.Max_Index then quote := S(Scanner.Index); Scanner.Index := Scanner.Index + 1; Scanner.First := Scanner.Index; while Scanner.Index <= Scanner.Max_Index and then S(Scanner.Index) /= quote loop Scanner.Index := Scanner.Index + 1; end loop; end if; Scanner.Length := Scanner.Index - Scanner.First; Scanner.Last := Scanner.Index - 1; if Scanner.Index <= Scanner.Max_Index and then S(Scanner.Index) = quote then -- Null string? Scanner.Index := Scanner.Index + 1; end if; end scan_Delimited; ---------------------------------------------------------------------------- procedure scan_Quoted( --| Scan quoted string Scanner: in out scanner_Type; S: in out string ) is quote: character; di: natural; begin Scanner.First := Scanner.Index; di := Scanner.Index; if Scanner.Index <= Scanner.Max_Index then quote := S(Scanner.Index); Scanner.Index := Scanner.Index + 1; Scanner.First := Scanner.Index; di := scanner.Index; while Scanner.Index <= Scanner.Max_Index loop if S(Scanner.Index) = quote then -- Closing quote? if Scanner.Index < Scanner.Max_Index and then S(Scanner.Index + 1) = quote then -- Doubled quote? Scanner.Index := Scanner.Index + 1; -- skip it else exit; -- Found closing quote at Scanner.Index end if; end if; S(di) := S(Scanner.Index); Scanner.Index := Scanner.Index + 1; di := di + 1; end loop; end if; Scanner.Length := di - Scanner.First; Scanner.Last := di - 1; Scanner.Index := Scanner.Index + 1; -- Skip closing quote end scan_Quoted; ---------------------------------------------------------------------------- -- Local function bodies: function is_Space(C: Character) return boolean is --| Return True iff C is a space or tab. begin return C = ' ' or else C = ASCII.HT; end is_Space; ---------------------------------------------------------------------------- end scanners; --:::::::::: --search.bdy --:::::::::: package body Search_Utilities is Version_Number : constant STRING := "1.1 (MOPR258)"; function Version return STRING is begin return Version_Number; end Version; procedure Search ( Component : in Component_Type; Search_Array : in Array_Type; Location_Found : out Index_Type; Component_Found : out BOOLEAN; Number_of_Comparisons : out Performance_Instrumentation_Type; Order_Strategy : in Data_Order_Type := Not_Ordered; No_Match_Index : in Index_Type := Index_Type'LAST) is Local_Comparisons : Performance_Instrumentation_Type := 0; -- The procedure below is a utility routine. procedure Update_Performance_Instrumentation ( Instrumentation_Count : in out Performance_Instrumentation_Type) is begin -- Bump the counter unless an overflow has occurred. if Instrumentation_Count /= Performance_Instrumentation_Type'FIRST then if Instrumentation_Count /= Performance_Instrumentation_Type'LAST then Instrumentation_Count := Instrumentation_Count + 1; else Instrumentation_Count := Performance_Instrumentation_Type'FIRST; end if; end if; end Update_Performance_Instrumentation; -- The two local procedures below perform two types of searches -- on the array: a binary search (if data is ordered), and -- a sequential search (if data is not ordered). procedure Binary_Search is High : Index_Type range Search_Array'FIRST .. Search_Array'LAST := Search_Array'LAST; Low : Index_Type range Search_Array'FIRST .. Search_Array'LAST := Search_Array'FIRST; Curr : Index_Type range Search_Array'FIRST .. Search_Array'LAST := Index_Type'VAL ((Index_Type'POS (High) + Index_Type'POS (Low)) / 2); begin while (Search_Array (Curr) /= Component) and (High > Low) loop Update_Performance_Instrumentation (Local_Comparisons); if Search_Array (Curr) < Component then if Curr = Search_Array'LAST then exit; -- Can't go any further, component not found. else Low := Index_Type'SUCC (Curr); end if; elsif Curr = Search_Array'FIRST then exit; -- Can't go any further, component not found. else High := Index_Type'PRED (Curr); end if; Curr := Index_Type'VAL ((Index_Type'POS (High) + Index_Type'POS (Low)) / 2); end loop; if Search_Array (Curr) = Component then Location_Found := Curr; Component_Found := TRUE; else Location_Found := No_Match_Index; Component_Found := FALSE; end if; end Binary_Search; -- Sequential_Search will search for the component starting at the -- beginning of the array. This search technique is used only if -- the user's data is not sorted. procedure Sequential_Search is Index : Index_Type range Search_Array'FIRST .. Search_Array'LAST := Search_Array'FIRST; begin while (Index /= Search_Array'LAST) and (Search_Array (Index) /= Component) loop Update_Performance_Instrumentation (Local_Comparisons); Index := Index_Type'SUCC (Index); end loop; if Search_Array (Index) = Component then Location_Found := Index; Component_Found := TRUE; else Location_Found := No_Match_Index; Component_Found := FALSE; end if; end Sequential_Search; -- Body of Search follows below. begin -- Check for null array... a special case. if Search_Array'LAST < Search_Array'FIRST then Location_Found := No_Match_Index; Component_Found := FALSE; else case Order_Strategy is when Not_Ordered => Sequential_Search; -- Search an unordered array. when Ordered => Binary_Search; -- Search an ordered array. end case; end if; Number_of_Comparisons := Local_Comparisons; end Search; -- The following overloading of Search is used when instrumentation -- analysis data are not required. procedure Search ( Component : in Component_Type; Search_Array : in Array_Type; Location_Found : out Index_Type; Component_Found : out BOOLEAN; Order_Strategy : in Data_Order_Type := Not_Ordered; No_Match_Index : in Index_Type := Index_Type'LAST) is Dummy_Comparisons : Performance_Instrumentation_Type; begin Search (Component, Search_Array, Location_Found, Component_Found, Dummy_Comparisons, Order_Strategy, No_Match_Index); end Search; -- The following overloading of Search should be used when only a -- boolean result is desired. function Search ( Component : in Component_Type; Search_Array : in Array_Type; Order_Strategy : in Data_Order_Type := Not_Ordered) return BOOLEAN is Component_Found : BOOLEAN; Dummy_Location : Index_Type; Dummy_Comparisons : Performance_Instrumentation_Type; begin Search (Component, Search_Array, Dummy_Location, Component_Found, Dummy_Comparisons, Order_Strategy); return Component_Found; end Search; -- The following overloading of Search should be used when only an -- index result is desired. function Search ( Component : in Component_Type; Search_Array : in Array_Type; Order_Strategy : in Data_Order_Type := Not_Ordered; No_Match_Index : in Index_Type := Index_Type'LAST) return Index_Type is Location_Found : Index_Type; Dummy_Component : BOOLEAN; Dummy_Comparisons : Performance_Instrumentation_Type; begin Search (Component, Search_Array, Location_Found, Dummy_Component, Dummy_Comparisons, Order_Strategy, No_Match_Index); return Location_Found; end Search; end Search_Utilities; --:::::::::: --slist.bdy --:::::::::: with Unchecked_Deallocation; package body Singly_Linked_List is -------------------------------------------------------------------------- -- Abstract : This package provides an abstraction for a singly linked -- list. -------------------------------------------------------------------------- -- Assumptions: -- The lists being manipulated must be in one of the following states -- both before and after execution of any subprogram in the package: -- (1) empty-list -- Head = null, Tail = null, -- Previous = null, Current = null -- (2) beginning-of-list -- Head /= null, Tail /= null -- Previous = null, Current = Head -- (3) inside-of-list -- Head /= null, Tail /= null -- Previous.Next = Current -- (4) outside-of-list -- Head /= null, Tail /= null -- Previous = null, Current = null ---------------------------------------------------------------------- function Empty (List : List_Type) return Boolean is -------------------------------------------------------------------------- -- Abstract : Indicates whether the list contains any elements. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be queried. -------------------------------------------------------------------------- begin return (List.Head = null); end Empty; function Null_Node (List : List_Type) return Boolean is -------------------------------------------------------------------------- -- Abstract : Indicates whether the "current pointer" references an -- element in the list. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be queried. -------------------------------------------------------------------------- begin return (List.Current = null); end Null_Node; function Head_Node (List : List_Type) return Boolean is -------------------------------------------------------------------------- -- Abstract : Indicates whether the "current pointer" references the -- head of the list. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be queried. -------------------------------------------------------------------------- begin return (List.Current = List.Head); end Head_Node; function Tail_Node (List : List_Type) return Boolean is -------------------------------------------------------------------------- -- Abstract : Indicates whether the "current pointer" references the -- tail of the list. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be queried. -------------------------------------------------------------------------- begin return (List.Current = List.Tail); end Tail_Node; function Current_Element (List : List_Type) return List_Element is -------------------------------------------------------------------------- -- Abstract : Returns the value of the element referenced by the -- "current pointer". -- Raises END_ERROR if NULL_NODE(LIST) = TRUE. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be queried. -------------------------------------------------------------------------- begin if List.Current = null then raise End_Error; else return List.Current.Element; end if; end Current_Element; procedure First (List : in out List_Type) is -------------------------------------------------------------------------- -- Abstract : Positions the "current pointer" at the head of the list -- (even if the list is empty). -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be modified. -------------------------------------------------------------------------- begin List.Previous := null; List.Current := List.Head; end First; procedure Next (List : in out List_Type) is -------------------------------------------------------------------------- -- Abstract : Positions the "current pointer" at the next element in the -- list. After the last element in the list NULL_NODE(LIST) -- becomes true. -- Raises END_ERROR if NULL_NODE(LIST) = TRUE. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be modified. -------------------------------------------------------------------------- begin if List.Current = null then raise End_Error; else if List.Current = List.Tail then List.Previous := null; else List.Previous := List.Current; end if; List.Current := List.Current.Next; end if; end Next; procedure Insert_After (List : in out List_Type; Element : List_Element) is -------------------------------------------------------------------------- -- Abstract : Inserts an element after the "current pointer". -- If NULL_NODE(LIST) = TRUE the element is appended after -- the tail element of the list. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be modified. -- ELEMENT - is the element to be inserted. -------------------------------------------------------------------------- begin if List.Current = null then List.Current := List.Tail; end if; if Empty (List) then List.Head := new Node'(Element, null); List.Tail := List.Head; List.Previous := null; List.Current := List.Head; else declare New_Node : Node_Access := new Node'(Element, List.Current.Next); begin if List.Current = List.Tail then List.Tail := New_Node; end if; List.Previous := List.Current; List.Previous.Next := New_Node; List.Current := New_Node; end; end if; end Insert_After; procedure Insert_Before (List : in out List_Type; Element : List_Element) is -------------------------------------------------------------------------- -- Abstract : Inserts an element before the "current pointer". -- If NULL_NODE(LIST) = TRUE the element is prepended before -- the head element of the list. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be modified. -- ELEMENT - is the element to be inserted. -------------------------------------------------------------------------- begin if List.Current = null then List.Current := List.Head; end if; if Empty (List) then List.Head := new Node'(Element, null); List.Tail := List.Head; List.Previous := null; List.Current := List.Head; elsif List.Current = List.Head then List.Head := new Node'(Element, List.Head); List.Previous := null; List.Current := List.Head; else List.Previous.Next := new Node'(Element, List.Current); List.Current := List.Previous.Next; end if; end Insert_Before; procedure Delete_Element (List : in out List_Type) is -------------------------------------------------------------------------- -- Abstract : Deletes the element referenced by the "current pointer" -- from the list. Upon deletion the "current pointer" -- references the element after the deleted element. -- Raises END_ERROR if NULL_NODE(LIST) = TRUE. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be modified. -------------------------------------------------------------------------- procedure Free is new Unchecked_Deallocation (Node, Node_Access); begin if List.Current = null then raise End_Error; elsif List.Current = List.Head then declare Next_Node : Node_Access := List.Head.Next; begin Free (List.Head); List.Head := Next_Node; if List.Head = null then List.Tail := null; end if; List.Current := List.Head; end; else if List.Current = List.Tail then List.Tail := List.Previous; end if; List.Previous.Next := List.Current.Next; Free (List.Current); List.Current := List.Previous.Next; if List.Current = null then List.Previous := null; end if; end if; end Delete_Element; procedure Modify (List : List_Type) is -------------------------------------------------------------------------- -- Abstract : Permits modification of the element referenced by the -- "current pointer" where the modification doesn't require -- external values (e.g. incrementing a field of the element). -- Raises END_ERROR if NULL_NODE(LIST) = TRUE. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be modified. -------------------------------------------------------------------------- begin if List.Current = null then raise End_Error; else Transformation (List.Current.Element); end if; end Modify; procedure Update (List : List_Type; Information : Update_Information) is -------------------------------------------------------------------------- -- Abstract : Permits modification of the element referenced by the -- "current pointer" where the modification requires -- external values (e.g. assigning a value to a field of -- the element). -- Raises END_ERROR if NULL_NODE(LIST) = TRUE. -------------------------------------------------------------------------- -- Parameters : LIST - is the list to be modified. -- INFORMATION - is the data necessary for the modification. -------------------------------------------------------------------------- begin if List.Current = null then raise End_Error; else Transformation (List.Current.Element, Information); end if; end Update; end Singly_Linked_List; --:::::::::: --sort.bdy --:::::::::: package body Sort_Utilities is Version_Number : constant STRING := "1.3 (FRAY297)"; --: function Ordered (A : in Array_Type) return BOOLEAN is --: begin --: for I in A'FIRST .. Index_Type'PRED (A'LAST) loop --: if A (Index_Type'SUCC (I)) < A (I) then --: return FALSE; --: end if; --: end loop; --: return TRUE; --: end Ordered; --: function Permutation (A, B : in Array_Type) return BOOLEAN is --: type Mark_Array_Type is array (A'RANGE) of BOOLEAN; --: Mark : Mark_Array_Type := (others => FALSE); --: Mark_Pos : Index_Type; --: Not_Marked : BOOLEAN; --: begin --: for I in A'RANGE loop --: Not_Marked := TRUE; --: for J in B'RANGE loop --: if Equal (A (I), B (J)) and not Mark (J) then --: Mark_Pos := J; --: exit; --: end if; --: end loop; --: if Not_Marked then --: return FALSE; --: else --: Mark (Mark_Pos) := TRUE; --: end if; --: end loop; --: return Mark = (others => TRUE); --: end Permutation; function Version return STRING is begin return Version_Number; end Version; -- The following subprograms are utilities for the sorting -- procedures that follow them. procedure Update_Performance_Instrumentation ( Instrumentation_Count : in out Performance_Instrumentation_Type) is begin -- Bump the counter unless an overflow has occurred. if Instrumentation_Count /= Performance_Instrumentation_Type'FIRST then if Instrumentation_Count /= Performance_Instrumentation_Type'LAST then Instrumentation_Count := Instrumentation_Count + 1; else Instrumentation_Count := Performance_Instrumentation_Type'FIRST; end if; end if; end Update_Performance_Instrumentation; procedure Exchange_Array_Components ( Sort_Array : in out Array_Type; Number_of_Exchanges : in out Performance_Instrumentation_Type) is Temporary_Component : constant Component_Type := Sort_Array (Sort_Array'FIRST); begin Sort_Array (Sort_Array'FIRST) := Sort_Array (Sort_Array'LAST); Sort_Array (Sort_Array'LAST) := Temporary_Component; Update_Performance_Instrumentation (Number_of_Exchanges); end Exchange_Array_Components; -- Procedure Quicksort is the default sort algorithm used. It is -- a non-recursive method of sorting by constantly partitioning the -- array in half and sorting only that half. This algorithm is -- O(NlogN) and is instable. procedure Quicksort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is type Sort_Array_Index_Save_Type is record Left, Right : Index_Type; end record; subtype Stack_Index_Type is NATURAL range 0 .. Sort_Array'LENGTH; type Stack_Array_Type is array (Stack_Index_Type) of Sort_Array_Index_Save_Type; Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; I, J, L, R : Index_Type; Temporary_Component : Component_Type; Stack_Pointer : Stack_Index_Type; Stack_Array : Stack_Array_Type; begin if Sort_Array'FIRST < Sort_Array'LAST then Stack_Pointer := 1; Stack_Array (1).Left := Sort_Array'FIRST; Stack_Array (1).Right := Sort_Array'LAST; loop -- Take top request from stack. L := Stack_Array (Stack_Pointer).Left; R := Stack_Array (Stack_Pointer).Right; Stack_Pointer := Stack_Pointer - 1; loop -- Split Sort_Array (Sort_Array'FIRST) .. Sort_Array (R). I := L; J := R; Temporary_Component := Sort_Array (Index_Type'VAL ( ((Index_Type'POS (L) + Index_Type'POS (R)) / 2))); loop loop Update_Performance_Instrumentation (Local_Comparisons); exit when (not (Sort_Array (I) < Temporary_Component)) or (I = Sort_Array'LAST); I := Index_Type'SUCC (I); end loop; loop Update_Performance_Instrumentation (Local_Comparisons); exit when (not (Temporary_Component < Sort_Array (J))) or (J = Sort_Array'FIRST); J := Index_Type'PRED (J); end loop; if I <= J then if I /= J then Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges); end if; if I /= Sort_Array'LAST then I := Index_Type'SUCC (I); end if; if J /= Sort_Array'FIRST then J := Index_Type'PRED (J); end if; end if; exit when I > J; end loop; if (Index_Type'POS (J) - Index_Type'POS (L)) < (Index_Type'POS (R) - Index_Type'POS (I)) then if I < R then -- Stack request for sorting right partition. Stack_Pointer := Stack_Pointer + 1; Stack_Array (Stack_Pointer).Left := I; Stack_Array (Stack_Pointer).Right := R; end if; R := J; -- Continue sorting left partition. else if L < J then -- Stack request for sorting left partition. Stack_Pointer := Stack_Pointer + 1; Stack_Array (Stack_Pointer).Left := L; Stack_Array (Stack_Pointer).Right := J; end if; L := I; -- Continue sorting right partition. end if; exit when L >= R; end loop; exit when Stack_Pointer = 0; end loop; end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Quicksort; -- The following procedure houses a Quicksort that is identical to -- the one above, except that recursion manages the state and paritions -- instead of an explicit stack. procedure Recursive_Quicksort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; -- The recursive nature of the sorting algorithm is found in -- the procedure below. procedure Recursive_Quick (Sort_Array : in out Array_Type) is I : Index_Type := Sort_Array'FIRST; J : Index_Type := Sort_Array'LAST; -- The partitioning of the array in half is found in the -- procedure below. It is this procedure that really sorts -- the array by making the necessary exchanges. -- This algorithm DEPENDS on the fact that there are two or -- more array components. Singleton or null arrays are special cases -- and should be handled by the outermost level of the -- Quicksort algorithm. procedure Partition is Sort_Array_Mid_Value : constant Component_Type := Sort_Array (Index_Type'VAL ((Index_Type'POS (I) + Index_Type'POS (J)) / 2)); begin loop while (Sort_Array (I) < Sort_Array_Mid_Value) and (I /= Sort_Array'LAST) loop Update_Performance_Instrumentation (Local_Comparisons); I := Index_Type'SUCC (I); end loop; while (Sort_Array_Mid_Value < Sort_Array (J)) and (J /= Sort_Array'FIRST) loop Update_Performance_Instrumentation (Local_Comparisons); J := Index_Type'PRED (J); end loop; if I <= J then if I < J then Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges); end if; if I /= Sort_Array'LAST then I := Index_Type'SUCC (I); end if; if J /= Sort_Array'FIRST then J := Index_Type'PRED (J); end if; end if; exit when (I > J) or ((I = Sort_Array'LAST) and (J = Sort_Array'FIRST)); end loop; end Partition; begin -- Recursive_Quick Partition; if Sort_Array'FIRST < J then Recursive_Quick (Sort_Array (Sort_Array'FIRST .. J)); end if; if I < Sort_Array'LAST then Recursive_Quick (Sort_Array (I .. Sort_Array'LAST)); end if; end Recursive_Quick; begin -- Recursive_Quicksort -- Handle the special cases of singleton and null arrays... -- do nothing. if Sort_Array'FIRST < Sort_Array'LAST then Recursive_Quick (Sort_Array); end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Recursive_Quicksort; -- A variation on Recursive_Quicksort is found in the procedure below. It -- is good for sorting data that is already ordered, partially ordered, -- or reverse ordered. The algorithm is O(NlogN) and instable. It is -- a combination of Recursive_Quicksort and Bubble_Sort_with_Quick_Exit. procedure Bsort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; -- The recursive nature of the algorithm is found in the procedure below. procedure Recursive_Bsort ( Low_Index, High_Index : in Index_Type; Mid_Component : in Component_Type) is Flag, Left_Flag, Right_Flag : BOOLEAN; I, J : Index_Type; Size : NATURAL; -- Sort_Array (Low_Index .. High_Index) are the components to be -- sorted, and Mid_Component is the value of the middle component. -- I and J are used to partition the subfiles so that at any time -- Sort_Array (I) < Mid_Component and (Mid_Component < Sort_Array (J) -- or Mid_Component = Sort_Array (J)). Left_Flag is TRUE whenever -- the left subfile is not in sorted order, and Right_Flag is -- TRUE whenever the right subfile is not in sorted order. Flag is -- FALSE when the partitioning processes are completed. begin if Low_Index < High_Index then Left_Flag := FALSE; Right_Flag := FALSE; I := Low_Index; J := High_Index; Flag := TRUE; while Flag loop loop Update_Performance_Instrumentation (Local_Comparisons); exit when (Mid_Component < Sort_Array (I)) or Equal (Mid_Component,Sort_Array (I)) or (I = J); -- Build the left subfile ensuring that the rightmost component -- is always the largest of the subfile. if I /= Low_Index then Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (I) < Sort_Array (Index_Type'PRED (I)) then Exchange_Array_Components ( Sort_Array (Index_Type'PRED (I) .. I),Local_Exchanges); Left_Flag := TRUE; end if; end if; I := Index_Type'SUCC (I); end loop; loop Update_Performance_Instrumentation (Local_Comparisons); exit when (Sort_Array (J) < Mid_Component) or (I = J); -- Build the right subfile ensuring that the leftmost component -- is always the smallest of the subfile. if J /= High_Index then Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then Exchange_Array_Components ( Sort_Array (J .. Index_Type'SUCC (J)),Local_Exchanges); Right_Flag := TRUE; end if; end if; J := Index_Type'PRED (J); end loop; if I /= J then -- Interchange Sort_Array (I) from the left subfile with -- Sort_Array (J) from the right subfile. Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges); else -- I = J -- Partitioning into left and right subfiles has been completed. Update_Performance_Instrumentation (Local_Comparisons); if (Mid_Component < Sort_Array (J)) or Equal (Mid_Component,Sort_Array (J)) then -- Check the right subfile to ensure the first component, -- Sort_Array (J), is the smallest. if J /= Sort_Array'LAST then Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then Exchange_Array_Components ( Sort_Array (J .. Index_Type'SUCC (J)),Local_Exchanges); Right_Flag := TRUE; end if; end if; else -- Check the left subfile to ensure the last component, -- Sort_Array (Index_Type'PRED (I)), is the largest. if I /= Sort_Array'FIRST then Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (I) < Sort_Array (Index_Type'PRED (I)) then Exchange_Array_Components ( Sort_Array (Index_Type'PRED (I) .. I),Local_Exchanges); Left_Flag := TRUE; end if; end if; if I > Index_Type'SUCC (Sort_Array'FIRST) then Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Index_Type'PRED (I)) < Sort_Array (Index_Type'PRED (Index_Type'PRED (I))) then Exchange_Array_Components ( Sort_Array (Index_Type'PRED (Index_Type'PRED (I)) .. Index_Type'PRED (I)),Local_Exchanges); end if; end if; end if; Flag := FALSE; end if; -- end of "if I /= J" end loop; -- end of "while Flag loop" -- Process the left subfile. Size := Index_Type'POS (I) - Index_Type'POS (Low_Index); if Size > 2 then -- Subfile must have at least three components to process and -- not already sorted. if Left_Flag then if Size = 3 then -- Special case of 3 components; place Sort_Array (Low_Index) -- and Sort_Array (Index_Type'SUCC (Low_Index)) in sorted order. Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Index_Type'SUCC (Low_Index)) < Sort_Array (Low_Index) then Exchange_Array_Components ( Sort_Array (Low_Index .. Index_Type'SUCC (Low_Index)), Local_Exchanges); end if; else Recursive_Bsort (Low_Index,Index_Type'PRED (Index_Type'PRED (I)), Sort_Array (Index_Type'VAL ( ((Index_Type'POS (Low_Index) + Index_Type'POS (I) - 2) / 2) ))); end if; end if; end if; -- Process the right subfile. Size := Index_Type'POS (High_Index) - Index_Type'POS (J) + 1; if Size > 2 then -- Subfile must have at least 3 components to process and not -- already sorted. if Right_Flag then if Size = 3 then -- Special case of 3 components; place -- Sort_Array (Index_Type'SUCC (J)) and -- Sort_Array (Index_Type'SUCC (Index_Type'SUCC (J))) in sorted -- order. Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Index_Type'SUCC (Index_Type'SUCC (J))) < Sort_Array (Index_Type'SUCC (J)) then Exchange_Array_Components ( Sort_Array (Index_Type'SUCC (J) .. Index_Type'SUCC (Index_Type'SUCC (J))), Local_Exchanges); end if; else Recursive_Bsort (Index_Type'SUCC (J),High_Index, Sort_Array (Index_Type'VAL ( ((Index_Type'POS (J) + Index_Type'POS (High_Index) + 1) / 2) ))); end if; end if; end if; end if; -- end of "if M < N then" end Recursive_Bsort; begin -- Bsort -- Do not bother with singleton and null arrays. if Sort_Array'FIRST < Sort_Array'LAST then Recursive_Bsort (Sort_Array'FIRST,Sort_Array'LAST, Sort_Array (Index_Type'VAL ( ((Index_Type'POS (Sort_Array'FIRST) + Index_Type'POS (Sort_Array'LAST)) / 2)))); end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Bsort; -- A bubble sort algorithm is found in the procedure below. The -- algorithm used is a standard bubble sort. This algorithm is -- O(N**2) and is stable. procedure Bubble_Sort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; begin -- Check for the singleton/null array cases... do nothing. if Sort_Array'FIRST < Sort_Array'LAST then for I in Sort_Array'FIRST .. Index_Type'VAL (Index_Type'POS (Sort_Array'LAST) - 1) loop for J in Sort_Array'FIRST .. Index_Type'VAL ( (Index_Type'POS (Sort_Array'LAST) + Index_Type'POS (Sort_Array'FIRST) - 1 ) - Index_Type'POS (I) ) loop Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then Exchange_Array_Components (Sort_Array (J .. Index_Type'SUCC (J)), Local_Exchanges); end if; end loop; end loop; end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Bubble_Sort; -- A bubble sort algorithm is found in the procedure below. The -- algorithm used is a standard bubble sort with a quick exit. The -- quick exit is taken if the data just happens to be sorted -- in the middle of the process. Thus, this algorithm may be faster -- than O(N**2) for arrays that are already partially ordered. procedure Bubble_Sort_with_Quick_Exit ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; Interchange_Made : BOOLEAN; begin -- Check for the singleton/null array cases... do nothing. if Sort_Array'FIRST < Sort_Array'LAST then for I in Sort_Array'FIRST .. Index_Type'VAL ( Index_Type'POS (Sort_Array'LAST) - 1) loop Interchange_Made := FALSE; for J in Sort_Array'FIRST .. Index_Type'VAL ( (Index_Type'POS (Sort_Array'LAST) + Index_Type'POS (Sort_Array'FIRST) - 1 ) - Index_Type'POS (I) ) loop Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then Interchange_Made := TRUE; Exchange_Array_Components (Sort_Array (J .. Index_Type'SUCC (J)), Local_Exchanges); end if; end loop; exit when not Interchange_Made; end loop; end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Bubble_Sort_with_Quick_Exit; -- A straight selection sort follows below. It is O(N**2) and -- is instable. procedure Selection_Sort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; Small : Index_Type; begin -- Check for singelton/null array case... do nothing. if Sort_Array'FIRST < Sort_Array'LAST then for I in Sort_Array'FIRST .. Index_Type'PRED (Sort_Array'LAST) loop Small := I; for J in Index_Type'SUCC (I) .. Sort_Array'LAST loop Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (J) < Sort_Array (Small) then Small := J; end if; end loop; if I /= Small then Exchange_Array_Components (Sort_Array (I .. Small),Local_Exchanges); end if; end loop; end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Selection_Sort; -- Heapsort follows below. It is O(NlogN) and is instable. procedure Heapsort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; I,J : Index_Type; Temporary_Component : Component_Type; begin -- Check for special array cases: do nothing on singleton/null, -- must handle an array of 2 elements separate since the algorithm -- assumes that Sort_Array'LENGTH >= 3. if Sort_Array'LENGTH = 2 then Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (Sort_Array'LAST) < Sort_Array (Sort_Array'FIRST) then Exchange_Array_Components (Sort_Array,Local_Exchanges); end if; elsif Sort_Array'FIRST < Sort_Array'LAST then -- Create initial heap. for K in Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop -- Insert Sort_Array (K) into existing heap of size K-1. I := K; Temporary_Component := Sort_Array (K); -- The complex expression in assigning to J below is necessary -- due to the generic nature of the algorithm. This -- expression is used in other places below too. if Index_Type'POS (I) >= 0 then J := Index_Type'VAL ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2); elsif ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) mod 2) = 0 then J := Index_Type'VAL ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2); else J := Index_Type'VAL ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 2) / 2); end if; while J >= Sort_Array'FIRST loop Update_Performance_Instrumentation (Local_Comparisons); exit when (Temporary_Component < Sort_Array (J)) or Equal (Temporary_Component,Sort_Array (J)); Update_Performance_Instrumentation (Local_Exchanges); Sort_Array (I) := Sort_Array (J); I := J; if Index_Type'POS (I) >= 0 then if (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >= Index_Type'POS (Sort_Array'FIRST) ) and (I /= Sort_Array'FIRST) then J := Index_Type'VAL ( (Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2); else exit; -- Exit while loop. end if; elsif ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) mod 2) = 0 then if (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >= Index_Type'POS (Sort_Array'FIRST) ) and (I /= Sort_Array'FIRST) then J := Index_Type'VAL ( (Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2); else exit; -- Exit while loop. end if; elsif (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >= Index_Type'POS (Sort_Array'FIRST) ) and (I /= Sort_Array'FIRST) then J := Index_Type'VAL ( (Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 2) / 2); else exit; -- Exit while loop. end if; end loop; -- End of while loop. Update_Performance_Instrumentation (Local_Comparisons); if not Equal (Temporary_Component,Sort_Array (I)) then Update_Performance_Instrumentation (Local_Exchanges); Sort_Array (I) := Temporary_Component; end if; end loop; -- End of for loop. -- We remove Sort_Array (Sort_Array'FIRST) and place it in its -- proper position in the array. We then adjust the heap. for K in reverse Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop Update_Performance_Instrumentation (Local_Exchanges); Temporary_Component := Sort_Array (K); Sort_Array (K) := Sort_Array (Sort_Array'FIRST); -- Readjust the heap of order K-1. Move Temporary_Component down the -- heap for proper position. I := Sort_Array'FIRST; J := Index_Type'SUCC (I); -- The following if statement can be described as follows: -- if (Sort_Array (Element#2) < Sort_Array (Element#3)) and -- (Position of K's predecessor >= Position of Element#3) then -- J := Position of Element#3; -- end if; -- The complications are due to the generic nature of the -- algorithm. Update_Performance_Instrumentation (Local_Comparisons); if ((Sort_Array (Index_Type'SUCC (Sort_Array'FIRST))) < (Sort_Array (Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST)))) ) and (Index_Type'PRED (K) >= Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST)) ) then J := Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST)); end if; -- J is the larger son of I in the heap of size K-1. while J <= Index_Type'PRED (K) loop Update_Performance_Instrumentation (Local_Comparisons); if (Sort_Array (J) < Temporary_Component) or Equal (Sort_Array (J),Temporary_Component) then exit; -- exit while loop end if; Update_Performance_Instrumentation (Local_Exchanges); Sort_Array (I) := Sort_Array (J); I := J; if (((Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1) <= Index_Type'POS (Index_Type'PRED (Sort_Array'LAST)) ) and (((Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1) >= Index_Type'POS (Sort_Array'FIRST) ) then J := Index_Type'VAL ( (Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1); else exit; -- Exit while loop. end if; if Index_Type'SUCC (J) <= Index_Type'PRED (K) then Update_Performance_Instrumentation (Local_Comparisons); if Sort_Array (J) < Sort_Array (Index_Type'SUCC (J)) then J := Index_Type'SUCC (J); end if; end if; end loop; -- End of while loop. Update_Performance_Instrumentation (Local_Exchanges); Sort_Array (I) := Temporary_Component; end loop; -- End of for loop. end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Heapsort; -- Simple insertion sort follows below. It is O(N**2), but usually -- better than a bubble sort. procedure Insertion_Sort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; I : Index_Type; Temporary_Component : Component_Type; Found : BOOLEAN; begin -- Handle special cases of singleton/null arrays... -- do nothing. if Sort_Array'FIRST < Sort_Array'LAST then -- Initially Sort_Array (Sort_Array'FIRST) may be thought of -- as a sorted file of one element. After each repetition of -- the following loop, the elements Sort_Array (Sort_Array'FIRST) -- through Sort_Array (K) are in order. for K in Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop -- insert Sort_Array (K) into the sorted file Temporary_Component := Sort_Array (K); -- Move down one position all elements "greater" than -- Temporary_Component I := Index_Type'PRED (K); Found := FALSE; while (not Found) loop Update_Performance_Instrumentation (Local_Comparisons); if Temporary_Component < Sort_Array (I) then Update_Performance_Instrumentation (Local_Exchanges); Sort_Array (Index_Type'SUCC (I)) := Sort_Array (I); if I /= Sort_Array'FIRST then I := Index_Type'PRED (I); else exit; -- Exit while loop. end if; else Found := TRUE; end if; end loop; -- End of while loop. -- Insert Temporary_Component at proper position. Update_Performance_Instrumentation (Local_Exchanges); if Found then Sort_Array (Index_Type'SUCC (I)) := Temporary_Component; else Sort_Array (Sort_Array'FIRST) := Temporary_Component; end if; end loop; -- End of for loop. end if; Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Insertion_Sort; -- The straight merge sort procedure below is O(NlogN) and is instable. procedure Merge_Sort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type) is Auxiliary_Array : Array_Type (Sort_Array'FIRST .. Sort_Array'LAST); Lower_Bound1, Lower_Bound2, Upper_Bound1, Upper_Bound2, Auxiliary_Index, I, J : Index_Type; I_Overflow, J_Overflow, Aux_Overflow : BOOLEAN; Size : POSITIVE := 1; -- Merge files of size 1. Local_Comparisons, Local_Exchanges : Performance_Instrumentation_Type := 0; begin while Size < Sort_Array'LENGTH loop Lower_Bound1 := Sort_Array'FIRST; Auxiliary_Index := Auxiliary_Array'FIRST; -- Check if there are two files to merge. while (Index_Type'POS (Lower_Bound1) + Size) <= Index_Type'POS (Sort_Array'LAST) loop I_Overflow := FALSE; J_Overflow := FALSE; Aux_Overflow := FALSE; -- Compute remaining indices. Lower_Bound2 := Index_Type'VAL (Index_Type'POS (Lower_Bound1) + Size); Upper_Bound1 := Index_Type'PRED (Lower_Bound2); if Index_Type'POS (Lower_Bound2) + Size - 1 > Index_Type'POS (Sort_Array'LAST) then Upper_Bound2 := Sort_Array'LAST; else Upper_Bound2 := Index_Type'VAL (Index_Type'POS (Lower_Bound2) + Size - 1); end if; -- Proceed through the two subfiles. I := Lower_Bound1; J := Lower_Bound2; while (I <= Upper_Bound1) and (J <= Upper_Bound2) loop -- Enter smaller into Auxiliary_Array. Update_Performance_Instrumentation (Local_Comparisons); Update_Performance_Instrumentation (Local_Exchanges); if (Sort_Array (I) < Sort_Array (J)) or Equal (Sort_Array (I),Sort_Array (J)) then Auxiliary_Array (Auxiliary_Index) := Sort_Array (I); if Auxiliary_Index /= Auxiliary_Array'LAST then Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index); else Aux_Overflow := TRUE; end if; if I /= Sort_Array'LAST then I := Index_Type'SUCC (I); else I_Overflow := TRUE; exit; end if; else Auxiliary_Array (Auxiliary_Index) := Sort_Array (J); if Auxiliary_Index /= Auxiliary_Array'LAST then Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index); else Aux_Overflow := TRUE; end if; if J /= Sort_Array'LAST then J := Index_Type'SUCC (J); else J_Overflow := TRUE; exit; end if; end if; end loop; -- While loop. -- At this point one of the subfiles has been exhausted. -- Insert any remaining portions of the other file. while (not I_Overflow) and (I <= Upper_Bound1) loop Update_Performance_Instrumentation (Local_Exchanges); Auxiliary_Array (Auxiliary_Index) := Sort_Array (I); if I /= Sort_Array'LAST then I := Index_Type'SUCC (I); else I_Overflow := TRUE; end if; if Auxiliary_Index /= Auxiliary_Array'LAST then Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index); else Aux_Overflow := TRUE; end if; end loop; while (not J_Overflow) and (J <= Upper_Bound2) loop Update_Performance_Instrumentation (Local_Exchanges); Auxiliary_Array (Auxiliary_Index) := Sort_Array (J); if J /= Sort_Array'LAST then J := Index_Type'SUCC (J); else J_Overflow := TRUE; end if; if Auxiliary_Index /= Auxiliary_Array'LAST then Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index); else Aux_Overflow := TRUE; end if; end loop; -- Advance Lower_Bound1 to start of next pair of files. if Index_Type'POS (Upper_Bound2) + 1 <= Index_Type'POS (Sort_Array'LAST) then Lower_Bound1 := Index_Type'SUCC (Upper_Bound2); else Lower_Bound1 := Sort_Array'LAST; end if; end loop; -- While loop. -- Copy any remaining single file. I := Lower_Bound1; while not Aux_Overflow loop Update_Performance_Instrumentation (Local_Exchanges); Auxiliary_Array (Auxiliary_Index) := Sort_Array (I); if Auxiliary_Index /= Auxiliary_Array'LAST then Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index); else Aux_Overflow := TRUE; end if; if I /= Sort_Array'LAST then I := Index_Type'SUCC (I); else I_Overflow := TRUE; end if; end loop; -- Adjust Sort_Array and Size. Sort_Array := Auxiliary_Array; Size := Size * 2; end loop; -- While loop. Number_of_Comparisons := Local_Comparisons; Number_of_Exchanges := Local_Exchanges; end Merge_Sort; procedure Sort ( Sort_Array : in out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type; Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is begin -- Call the right sorting algorithm. case Sort_Algorithm is when Quicksort => Quicksort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Recursive_Quicksort => Recursive_Quicksort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Bsort => Bsort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Bubble_Sort => Bubble_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Bubble_Sort_with_Quick_Exit => Bubble_Sort_with_Quick_Exit (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Selection_Sort => Selection_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Heapsort => Heapsort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Insertion_Sort => Insertion_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); when Merge_Sort => Merge_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges); end case; end Sort; -- Overloading of procedure Sort that does not return instrumentation -- analysis data follows below. procedure Sort ( Sort_Array : in out Array_Type; Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is Dummy_Comparisons, Dummy_Exchanges : Performance_Instrumentation_Type; begin Sort (Sort_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm); end Sort; -- Overloading of procedure Sort used to preserve original data and to -- return instrumentation analysis results follows below. procedure Sort ( Unsorted_Array : in Array_Type; Sorted_Array : out Array_Type; Number_of_Comparisons, Number_of_Exchanges : out Performance_Instrumentation_Type; Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is Local_Array : Array_Type (Unsorted_Array'RANGE) := Unsorted_Array; begin Number_of_Comparisons := 0; Number_of_Exchanges := 0; -- Check for equal length of both arrays. if Unsorted_Array'LENGTH /= Sorted_Array'LENGTH then raise Sort_Arrays_Length_Mismatch; end if; Sort (Local_Array,Number_of_Comparisons,Number_of_Exchanges, Sort_Algorithm); Sorted_Array := Local_Array; end Sort; -- Overloading of procedure Sort used to preserve the original data -- follows below. procedure Sort ( Unsorted_Array : in Array_Type; Sorted_Array : out Array_Type; Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is Local_Array : Array_Type (Unsorted_Array'RANGE) := Unsorted_Array; Dummy_Comparisons, Dummy_Exchanges : Performance_Instrumentation_Type; begin -- Check for equal length of both arrays. if Unsorted_Array'LENGTH /= Sorted_Array'LENGTH then raise Sort_Arrays_Length_Mismatch; end if; Sort (Local_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm); Sorted_Array := Local_Array; end Sort; -- Overloading of function Sort used in inline expressions follows below. function Sort ( Sort_Array : in Array_Type; Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) return Array_Type is Sorted_Array : Array_Type (Sort_Array'RANGE) := Sort_Array; Dummy_Comparisons, Dummy_Exchanges : Performance_Instrumentation_Type; begin Sort (Sorted_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm); return Sorted_Array; end Sort; end Sort_Utilities; --:::::::::: --stringer.bdy --:::::::::: package body STRING_MANIPULATOR is procedure LOAD (FROM : in STRING; TO : out STRING; FILL_CHARACTER : in CHARACTER := ' ') is --========================= PDL =========================== --|ABSTRACT: --| LOAD loads the TO string with the content of the --| FROM string. If the TO string is longer than the --| FROM string, the TO string is right-filled with the --| FILL_CHARACTER. If the TO string is shorter than --| the FROM string, the slice of the FROM string that --| will fit in the TO string will be copied into the TO --| string. --|DESIGN DESCRIPTION: --| If the length of the TO string is greater than or --| equal to the length of the FROM string --| Copy the FROM string into the first slice of the --| TO string --| Copy the FILL_CHARACTER into the rest of the TO --| string --| Else --| Copy the first slice of the FROM string into the --| TO string --| End if --========================================================= begin if TO'LENGTH >= FROM'LENGTH then TO (TO'FIRST .. TO'FIRST + FROM'LENGTH - 1) := FROM; TO (TO'FIRST + FROM'LENGTH .. TO'LAST) := (others => FILL_CHARACTER); else TO := FROM (FROM'FIRST .. FROM'FIRST + TO'LENGTH - 1); end if; end LOAD; procedure LOAD (FROM : in STRING; TO : out STRING; LAST : out NATURAL; FILL_CHARACTER : in CHARACTER := ' ') is --========================= PDL =========================== --|ABSTRACT: --| LOAD loads the TO string with the content of the --| FROM string. If the TO string is longer than the --| FROM string, the TO string is right-filled with the --| FILL_CHARACTER. If the TO string is shorter than --| the FROM string, the slice of the FROM string that --| will fit in the TO string will be copied into the TO --| string. LOAD also returns the number of characters --| in FROM string as the variable LAST. --|DESIGN DESCRIPTION: --| If the length of the TO string is greater than or --| equal to the length of the FROM string --| Copy the FROM string into the first slice of the --| TO string --| Copy the FILL_CHARACTER into the rest of the TO --| string --| Set LAST to FROM'LENGTH + TO'FIRST - 1 --| Else --| Copy the first slice of the FROM string into the --| TO string --| Set LAST to TO'LAST --| End if --========================================================= begin if TO'LENGTH >= FROM'LENGTH then TO (TO'FIRST .. TO'FIRST + FROM'LENGTH - 1) := FROM; TO (TO'FIRST + FROM'LENGTH .. TO'LAST) := (others => FILL_CHARACTER); LAST := FROM'LENGTH + TO'FIRST - 1; else TO := FROM (FROM'FIRST .. FROM'FIRST + TO'LENGTH - 1); LAST := TO'LAST; end if; end LOAD; procedure GUARDED_LOAD (FROM : in STRING; TO : out STRING; FILL_CHARACTER : in CHARACTER := ' ') is --========================= PDL =========================== --|ABSTRACT: --| GUARDED_LOAD loads the TO string with the content of --| the FROM string. If the TO string is longer than the --| FROM string, the TO string is right-filled with the --| FILL_CHARACTER. If the TO string is shorter than --| the FROM string, STRING_OVERFLOW is raised. --|DESIGN DESCRIPTION: --| If the length of the TO string is greater than or --| equal to the length of the FROM string --| Copy the FROM string into the first slice of the --| TO string --| Copy the FILL_CHARACTER into the rest of the TO --| string --| Else --| Raise STRING_OVERFLOW --| End if --========================================================= begin if TO'LENGTH >= FROM'LENGTH then TO (TO'FIRST .. TO'FIRST + FROM'LENGTH - 1) := FROM; TO (TO'FIRST + FROM'LENGTH .. TO'LAST) := (others => FILL_CHARACTER); else raise STRING_OVERFLOW; end if; end GUARDED_LOAD; procedure GUARDED_LOAD (FROM : in STRING; TO : out STRING; LAST : out NATURAL; FILL_CHARACTER : in CHARACTER := ' ') is --========================= PDL =========================== --|ABSTRACT: --| GUARDED_LOAD loads the TO string with the content of --| the FROM string. If the TO string is longer than the --| FROM string, the TO string is right-filled with the --| FILL_CHARACTER. If the TO string is shorter than --| the FROM string, STRING_OVERFLOW is raised. LAST is --| the index of the FROM character in the TO string. --|DESIGN DESCRIPTION: --| If the length of the TO string is greater than or --| equal to the length of the FROM string --| Copy the FROM string into the first slice of the --| TO string --| Copy the FILL_CHARACTER into the rest of the TO --| string --| Set LAST to FROM'LENGTH + TO'FIRST - 1 --| Else --| Raise STRING_OVERFLOW --| End if --========================================================= begin if TO'LENGTH >= FROM'LENGTH then TO (TO'FIRST .. TO'FIRST + FROM'LENGTH - 1) := FROM; TO (TO'FIRST + FROM'LENGTH .. TO'LAST) := (others => FILL_CHARACTER); LAST := FROM'LENGTH + TO'FIRST - 1; else raise STRING_OVERFLOW; end if; end GUARDED_LOAD; procedure FILL (WHAT : out STRING; WITH_ITEM : in CHARACTER := ' ') is --========================= PDL =========================== --|ABSTRACT: --| FILL fills the string WHAT with the character --| WITH_ITEM. --|DESIGN DESCRIPTION: --| Loop over WHAT'RANGE --| Store WITH_ITEM into WHAT(I) --| End Loop --========================================================= begin for I in WHAT'RANGE loop WHAT (I) := WITH_ITEM; end loop; end FILL; function IS_FILLED (WHAT : in STRING; WITH_ITEM : in CHARACTER := ' ') return BOOLEAN is --========================= PDL =========================== --|ABSTRACT: --| IS_FILLED returns TRUE if all characters of the --| string WHAT are equal to WITH_ITEM. FALSE is --| returned otherwise. --|DESIGN DESCRIPTION: --| Initialize RESULT to TRUE --| Loop over WHAT'RANGE --| If WHAT(I) is not equal to WITH_ITEM, exit with --| RESULT set to FALSE --| End Loop --| Return RESULT --========================================================= RESULT : BOOLEAN := TRUE; begin for I in WHAT'RANGE loop if WHAT (I) /= WITH_ITEM then RESULT := FALSE; exit ; end if; end loop; return RESULT; end IS_FILLED; end STRING_MANIPULATOR; --:::::::::: --testlog.bdy --:::::::::: -- ************************************************** -- * * -- * Test_Log * BODY -- * * -- ************************************************** with Text_IO; package body Test_Log is --| Notes (none) File_Report : BOOLEAN := FALSE; FID : Text_IO.FILE_TYPE; Test_Counter : NATURAL := 0; Error_Counter : NATURAL := 0; Indent_String : constant STRING := " "; Current_Mode : MODE := SILENT; Fill_String : constant STRING := " "; -- 60 Test_ID_Field_Length : NATURAL; String_Field_Length : NATURAL; Integer_Field_Length : NATURAL; Float_Fore_Field_Length : NATURAL; Float_Aft_Field_Length : NATURAL; Float_Exp_Field_Length : NATURAL; package Int_IO is new Text_IO.Integer_IO(INTEGER); package Flt_IO is new Text_IO.Float_IO(FLOAT); -- .................................................. -- . . -- . Test_Log.To_ID . SPEC & BODY -- . . -- .................................................. function To_ID(S : in STRING) return STRING is begin if S'LENGTH < Test_ID_Field_Length then return S & Fill_String(1..Test_ID_Field_Length-S'LENGTH); else return S; end if; end To_ID; -- .................................................. -- . . -- . Test_Log.To_String . SPEC & BODY -- . . -- .................................................. function To_String(S : in STRING) return STRING is begin if S'LENGTH < String_Field_Length then return """" & S & """" & Fill_String(1..String_Field_Length-S'LENGTH); else return """" & S & """"; end if; end To_String; -- .................................................. -- . . -- . Test_Log.Show_Result . SPEC & BODY -- . . -- .................................................. function Show_Result(R : in TEST_RESULT) return STRING is begin return TEST_RESULT'IMAGE(R); end Show_Result; -- .................................................. -- . . -- . Test_Log.Set_Mode . BODY -- . . -- .................................................. procedure Set_Mode (To : in MODE) is Looping : BOOLEAN := TRUE; Inline : STRING(1..10); Inlast : NATURAL; begin case To is when USER_SELECTABLE => while Looping loop Text_IO.Put("Enter Test Mode (F=File, V=Verbose, S=Silent): "); Text_IO.Get_Line(Inline, Inlast); if Inlast > 0 then case Inline(1) is when 'f' | 'F' => Current_Mode := VERBOSE; if not File_Report then File_Report := TRUE; begin Text_IO.Create(FID, Text_IO.OUT_FILE, Test_Log_File); Text_IO.Put_Line ("Output file " & Test_Log_File & " created"); exception when others => Text_IO.Put_Line ("Cannot create output file " & Test_Log_File); raise REPORT_FILE_ERROR; end; Text_IO.Set_Output(FID); end if; Looping := FALSE; when 's' | 'S' => Current_Mode := SILENT; Looping := FALSE; when 'v' | 'V' => Current_Mode := VERBOSE; Looping := FALSE; when others => Text_IO.Put_Line(" Invalid input -- retry"); end case; end if; end loop; when REPORT_TO_FILE => Current_Mode := VERBOSE; if not File_Report then File_Report := TRUE; begin Text_IO.Create(FID, Text_IO.OUT_FILE, Test_Log_File); Text_IO.Put_Line ("Output file " & Test_Log_File & " created"); exception when others => Text_IO.Put_Line ("Cannot create output file " & Test_Log_File); raise REPORT_FILE_ERROR; end; Text_IO.Set_Output(FID); end if; when VERBOSE | SILENT => Current_Mode := To; end case; end Set_Mode; -- .................................................. -- . . -- . Test_Log.Set_Test_ID_Field_Width . BODY -- . . -- .................................................. procedure Set_Test_ID_Field_Width (To : in NATURAL := 10) is begin Test_ID_Field_Length := To; end Set_Test_ID_Field_Width; -- .................................................. -- . . -- . Test_Log.Set_String_Field_Width . BODY -- . . -- .................................................. procedure Set_String_Field_Width (To : in NATURAL := 20) is begin String_Field_Length := To; end Set_String_Field_Width; -- .................................................. -- . . -- . Test_Log.Set_Integer_Field_Width . BODY -- . . -- .................................................. procedure Set_Integer_Field_Width (To : in NATURAL := 20) is begin Integer_Field_Length := To; end Set_Integer_Field_Width; -- .................................................. -- . . -- . Test_Log.Set_Float_Field_Width . BODY -- . . -- .................................................. procedure Set_Float_Field_Width (Before_Decimal : in NATURAL := 2; After_Decimal : in NATURAL := 5; In_Exponent : in NATURAL := 4) is begin Float_Fore_Field_Length := Before_Decimal; Float_Aft_Field_Length := After_Decimal; Float_Exp_Field_Length := In_Exponent; end Set_Float_Field_Width; -- .................................................. -- . . -- . Test_Log.Reset . BODY -- . . -- .................................................. procedure Reset is begin Test_Counter := 0; Error_Counter := 0; end Reset; -- .................................................. -- . . -- . Test_Log.Compare . BODY -- . . -- .................................................. procedure Compare(Test_ID : in STRING; Expected_Result : in STRING; Actual_Result : in STRING) is Result : TEST_RESULT := PASS; begin Test_Counter := Test_Counter + 1; if Expected_Result /= Actual_Result then Result := FAIL; Error_Counter := Error_Counter + 1; if Current_Mode = SILENT then Text_IO.Put_Line(Test_ID); end if; end if; if Current_Mode = VERBOSE then Text_IO.Put_Line(To_ID(Test_ID) & " " & To_String(Expected_Result) & " " & To_String(Actual_Result) & " " & Show_Result(Result)); end if; end Compare; -- .................................................. -- . . -- . Test_Log.Compare . BODY -- . . -- .................................................. procedure Compare(Test_ID : in STRING; Expected_Result : in INTEGER; Actual_Result : in INTEGER) is Result : TEST_RESULT := PASS; begin Test_Counter := Test_Counter + 1; if Expected_Result /= Actual_Result then Result := FAIL; Error_Counter := Error_Counter + 1; if Current_Mode = SILENT then Text_IO.Put_Line(Test_ID); end if; end if; if Current_Mode = VERBOSE then Text_IO.Put(To_ID(Test_ID) & " "); Int_IO.Put(Expected_Result, Integer_Field_Length); Text_IO.Put(" "); Int_IO.Put(Actual_Result, Integer_Field_Length); Text_IO.Put_Line(" " & Show_Result(Result)); end if; end Compare; -- .................................................. -- . . -- . Test_Log.Compare . BODY -- . . -- .................................................. procedure Compare(Test_ID : in STRING; Expected_Result : in FLOAT; Actual_Result : in FLOAT; Tolerance : in FLOAT) is Result : TEST_RESULT := PASS; begin Test_Counter := Test_Counter + 1; if abs(Expected_Result - Actual_Result) > Tolerance then Result := FAIL; Error_Counter := Error_Counter + 1; if Current_Mode = SILENT then Text_IO.Put_Line(Test_ID); end if; end if; if Current_Mode = VERBOSE then Text_IO.Put(To_ID(Test_ID) & " "); Flt_IO.Put(Expected_REsult, Float_Fore_Field_Length, Float_Aft_Field_Length, Float_Exp_Field_Length); Text_IO.Put(" "); Flt_IO.Put(Actual_Result, Float_Fore_Field_Length, Float_Aft_Field_Length, Float_Exp_Field_Length); Text_IO.Put_Line(" " & Show_Result(Result)); end if; end Compare; -- .................................................. -- . . -- . Test_Log.Enter_Test_Result . BODY -- . . -- .................................................. procedure Enter_Test_Result(Test_ID : in STRING; Result : in TEST_RESULT) is begin Test_Counter := Test_Counter + 1; if Result = FAIL then Error_Counter := Error_Counter + 1; if Current_Mode = SILENT then Text_IO.Put_Line(Test_ID); end if; end if; if Current_Mode = VERBOSE then Text_IO.Put_Line(To_ID(Test_ID) & " " & Show_Result(Result)); end if; end Enter_Test_Result; -- .................................................. -- . . -- . Test_Log.Error_Count . BODY -- . . -- .................................................. function Error_Count return NATURAL is begin return Error_Counter; end Error_Count; -- .................................................. -- . . -- . Test_Log.Test_Count . BODY -- . . -- .................................................. function Test_Count return NATURAL is begin return Test_Counter; end Test_Count; -- .................................................. -- . . -- . Test_Log.Write . BODY -- . . -- .................................................. procedure Write(Message : in STRING := "") is begin Text_IO.Put_Line(Message); end Write; -- .................................................. -- . . -- . Test_Log.Report . BODY -- . . -- .................................................. procedure Report(Message : in STRING := "") is Indent : BOOLEAN := FALSE; begin if Message'Length > 0 then Text_IO.Put_Line(Message); Indent := TRUE; end if; if Indent then Text_IO.Put(Indent_String); end if; Text_IO.Put_Line("Test Counter = " & NATURAL'IMAGE(Test_Counter)); if Indent then Text_IO.Put(Indent_String); end if; Text_IO.Put_Line("Error Counter = " & NATURAL'IMAGE(Error_Counter)); end Report; -- .................................................. -- . . -- . Test_Log.Close . BODY -- . . -- .................................................. procedure Close is begin if File_Report then Text_IO.Close(FID); File_Report := FALSE; Text_IO.Set_Output(Text_IO.Standard_Output); end if; end Close; begin -- Initialize Test_Log Set_Test_ID_Field_Width; Set_String_Field_Width; Set_Integer_Field_Width; Set_Float_Field_Width; end Test_Log; --:::::::::: --binfile.bdy --:::::::::: -- ************************************************** -- * * -- * Binary_File * BODY -- * * -- ************************************************** with CS_Parts_Types; -- for BYTE type use CS_Parts_Types; with Sequential_IO; with Unchecked_Deallocation; package body Binary_File is --| Notes (none) package BIO is new Sequential_IO(BYTE); type FILE_OBJECT is record F : BIO.FILE_TYPE; end record; procedure Free is new Unchecked_Deallocation (FILE_OBJECT, FILE_TYPE); -- ................................................... -- . . -- . Binary_File.Create . BODY -- . . -- ................................................... procedure Create (File : in out FILE_TYPE; Name : in STRING) is --| Exceptions --| Device_Error -- raised if file cannot be created --| -- due to a hardware error --| Name_Error -- raised if Name is not a valid file --| -- or directory reference --| Status_Error -- raised if file Name is already --| -- open --| Use_Error -- raised if file Name exists and is --| -- read/only --| --| Notes (none) begin -- Create File := new FILE_OBJECT; BIO.Create (File.F, BIO.OUT_FILE, Name); exception when BIO.Device_Error => raise Device_Error; when BIO.Name_Error => raise Name_Error; when BIO.Status_Error => raise Status_Error; when BIO.Use_Error => raise Use_Error; when others => raise Unexpected_Error; end Create; -- ................................................... -- . . -- . Binary_File.Open . BODY -- . . -- ................................................... procedure Open (File : in out FILE_TYPE; Name : in STRING) is --| Exceptions --| Device_Error -- raised if file cannot be opened --| -- due to a hardware error --| Name_Error -- raised if Name is not a valid file --| -- or directory reference --| Status_Error -- raised if file Name is already --| -- open --| Use_Error -- raised if file Name is write/only --| --| Notes (none) begin -- Open File := new FILE_OBJECT; BIO.Open (File.F, BIO.IN_FILE, Name); exception when BIO.Device_Error => raise Device_Error; when BIO.Name_Error => raise Name_Error; when BIO.Status_Error => raise Status_Error; when BIO.Use_Error => raise Use_Error; when others => raise Unexpected_Error; end Open; -- ................................................... -- . . -- . Binary_File.Close . BODY -- . . -- ................................................... procedure Close (File : in out FILE_TYPE) is --| Notes (none) begin -- Close BIO.Close (File.F); Free (File); exception when others => raise Unexpected_Error; end Close; -- ................................................... -- . . -- . Binary_File.Reset . SPEC -- . . -- ................................................... procedure Reset (File : in out FILE_TYPE; Mode : in FILE_MODE := IN_FILE) is --| Exceptions --| Device_Error -- raised if file cannot be accessed --| -- due to a hardware error --| Name_Error -- raised if Name is not a valid file --| -- or directory reference --| Status_Error -- raised if file Name is already --| -- open --| Use_Error -- raised if file Name exists and is --| -- read/only --| --| Notes (none) begin -- Reset case Mode is when IN_FILE => BIO.Reset (File.F, BIO.IN_FILE); when OUT_FILE => BIO.Reset (File.F, BIO.OUT_FILE); end case; exception when BIO.Device_Error => raise Device_Error; when BIO.Name_Error => raise Name_Error; when BIO.Status_Error => raise Status_Error; when BIO.Use_Error => raise Use_Error; when others => raise Unexpected_Error; end Reset; -- ................................................... -- . . -- . Binary_File.Mode . BODY -- . . -- ................................................... function Mode (File : in FILE_TYPE) return FILE_MODE is --| Notes (none) Result1 : BIO.FILE_MODE; Result : FILE_MODE; begin -- Mode Result1 := BIO.Mode (File.F); case Result1 is when BIO.IN_FILE => Result := IN_FILE; when BIO.OUT_FILE => Result := OUT_FILE; end case; return Result; exception when others => raise Unexpected_Error; end Mode; -- ................................................... -- . . -- . Binary_File.Name . BODY -- . . -- ................................................... function Name (File : in FILE_TYPE) return STRING is --| Notes (none) begin -- Name return BIO.Name (File.F); exception when others => raise Unexpected_Error; end Name; -- ................................................... -- . . -- . Binary_File.Is_Open . BODY -- . . -- ................................................... function Is_Open (File : in FILE_TYPE) return BOOLEAN is --| Notes (none) begin -- Is_Open return BIO.Is_Open (File.F); exception when others => raise Unexpected_Error; end Is_Open; -- ................................................... -- . . -- . Binary_File.Is_End . BODY -- . . -- ................................................... function Is_End (File : in FILE_TYPE) return BOOLEAN is --| Notes (none) begin -- Is_End return BIO.End_of_File (File.F); exception when others => raise Unexpected_Error; end Is_End; -- ................................................... -- . . -- . Binary_File.Read . BODY -- . . -- ................................................... procedure Read (File : in FILE_TYPE; Item : out BYTE) is --| Exceptions --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| End_Error -- raised if the next byte to be --| -- returned is beyond the end of --| -- the File --| Mode_Error -- raised if File is opened for --| -- output (mode OUT_FILE) --| Status_Error -- raised if File has not been --| -- OPENed --| --| Notes (none) begin -- Read BIO.Read (File.F, Item); exception when BIO.Device_Error => raise Device_Error; when BIO.End_Error => raise End_Error; when BIO.Mode_Error => raise Mode_Error; when BIO.Status_Error => raise Status_Error; when others => raise Unexpected_Error; end Read; -- ................................................... -- . . -- . Binary_File.Read . BODY -- . . -- ................................................... procedure Read (File : in FILE_TYPE; Item : out BLOCK) is --| Exceptions --| Data_Error -- raised if a full BLOCK could --| -- not be read from the file --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| End_Error -- raised if the next byte to be --| -- returned is beyond the end of --| -- the File --| Mode_Error -- raised if File is opened for --| -- output (mode OUT_FILE) --| Status_Error -- raised if File has not been --| -- OPENed --| --| Notes (none) Next_Byte : BYTE; begin -- Read for I in Item'First .. Item'Last loop begin BIO.Read (File.F, Next_Byte); exception when BIO.End_Error => if I = Item'First then raise End_Error; else raise Data_Error; end if; when others => raise; end; Item(I) := Next_Byte; end loop; exception when BIO.Device_Error => raise Device_Error; when BIO.Mode_Error => raise Mode_Error; when BIO.Status_Error => raise Status_Error; when End_Error | Data_Error => raise; when others => raise Unexpected_Error; end Read; -- ................................................... -- . . -- . Binary_File.Write . BODY -- . . -- ................................................... procedure Write (File : in FILE_TYPE; Item : in BYTE) is --| Exceptions --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| Mode_Error -- raised if File is opened for --| -- input (mode IN_FILE) --| Status_Error -- raised if File has not been --| -- CREATEd --| --| Notes (none) begin -- Write BIO.Write (File.F, Item); exception when BIO.Device_Error => raise Device_Error; when BIO.Mode_Error => raise Mode_Error; when BIO.Status_Error => raise Status_Error; when others => raise Unexpected_Error; end Write; -- ................................................... -- . . -- . Binary_File.Write . BODY -- . . -- ................................................... procedure Write (File : in FILE_TYPE; Item : in BLOCK) is --| Exceptions --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| Mode_Error -- raised if File is opened for --| -- input (mode IN_FILE) --| Status_Error -- raised if File has not been --| -- CREATEd --| --| Notes (none) begin -- Write for I in Item'First .. Item'Last loop BIO.Write (File.F, Item(I)); end loop; exception when BIO.Device_Error => raise Device_Error; when BIO.Mode_Error => raise Mode_Error; when BIO.Status_Error => raise Status_Error; when others => raise Unexpected_Error; end Write; end Binary_File; --:::::::::: --bintree2.bdy --:::::::::: with unchecked_deallocation; package body Binarytrees is ---------------------------------------------------------------------------- -- Local Subprograms ---------------------------------------------------------------------------- procedure Free is new unchecked_deallocation (Node, Tree); function equal (X, Y: in ItemType) return boolean is begin return (not (X < Y)) and (not (Y < X)); end; ------------------------------------------------------------------------------ function generate (T :in Tree ) return Nodeorder.List is L : Nodeorder.List; --| This routine generates a list of pointers to nodes in the tree t. --| The list is ordered with respect to the order of the nodes in the tree. --| generate does a depth first search of the tree. --| 1. It first visits the leftchild of t and generates the list for that. --| 2. It then appends the root node of t to the list generated for the left --| child. --| 3. It then appends the list generated for the rightchild to the list --| generated for the leftchild and the root. --| begin L := NodeOrder.Create; if T /= null then L := Generate (T.Leftchild); Nodeorder.Attach (L, T); Nodeorder.Attach (L, Generate (T.Rightchild)); end if; return L; End Generate; ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Visible Subprograms ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ function Create return Tree is begin return null; end; ----------------------------------------------------------------------------- procedure Deposit ( I :in ItemType; S :in Tree ) is begin S.Info := I; end; ------------------------------------------------------------------------------ procedure DestroyTree ( T :in out Tree) is --| This procedure recursively destroys the tree T. --| 1. It destroy the leftchild of T --| 2. It then destroys the rightchild of T. --| 3. It then destroy the root T and set T to be null. begin if T.leftchild /= null then DestroyTree (T.leftchild); DestroyTree (T.rightchild); Free (T); end if; end DestroyTree; ------------------------------------------------------------------------------ procedure InsertNode ( N :in out ItemType; --| Node being inserted. T :in out Tree; --| Tree node is being inserted --| into. Root : out Tree; --| Root of the subtree which node N --| heads. This is the position of --| node N in T; Exists : out boolean --| If this node already exists in --| the tree then Exists is true. If --| If this is the first insertion --| Exists is false. ) is --| This inserts the node N in T. --| 1. If T is null then a new node is allocated and assigned to T --| 2. If T is not null then T is searched for the proper place to insert n. --| This is first done by checking whether N < rightchild --| 3. If this is not true then we check to see if leftchild < N --| 4. If this is not true then N is in the tree. begin if T = null then T := new Node ' (Info => N, leftchild => null, rightchild => null); Root := T; Exists := false; N := T.Info; elsif N < T.Info then InsertNode (N, T.leftchild, Root, Exists); elsif T.Info < N then InsertNode (N, T.rightchild, Root, Exists); else Root := T; Exists := true; N := T.Info; end if; end InsertNode; ------------------------------------------------------------------------------ function MakeTreeIter (T :in Tree ) return TreeIter is I :TreeIter; --| This sets up the iterator for a tree T. --| The NodeList keeps track of the order of the nodes of T. The NodeList --| is computed by first invoking Generate of the leftchild then append --| the root node to NodeList and then append the result of Generate --| to NodeList. Since the tree is ordered such that --| --| leftchild < root root < rightchild --| --| NodeOrder returns the nodes in ascending order. --| --| Thus NodeList keeps the list alive for the duration of the iteration --| operation. The variable State is the a pointer into the NodeList --| which is the current place of the iteration. begin I.NodeList := NodeOrder.Create; if T /= null then I.NodeList := Generate (T.leftchild); NodeOrder.Attach (I.NodeList, T); NodeOrder.Attach (I.NodeList, Generate (T.rightChild)); end if; I.State := NodeOrder.MakeListIter (I.NodeList); return I; end; ------------------------------------------------------------------------------ function More (I :in TreeIter) return boolean is begin return NodeOrder.More (I.State); end; ------------------------------------------------------------------------------ procedure Next ( I :in out TreeIter; Info : out ItemType ) is T: Tree; --| Next returns the information at the current position in the iterator --| and increments the iterator. This is accomplished by using the iterater --| associated with the NodeOrder list. This returns a pointer into the Tree --| and then the information found at this node in T is returned. begin NodeOrder.Next (I.State, T); Info := T.Info; end; ------------------------------------------------------------------------------- end BinaryTrees;